[cig-commits] r12002 - in seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta: . scripts setup src
lcarring at geodynamics.org
lcarring at geodynamics.org
Thu May 22 11:29:41 PDT 2008
Author: lcarring
Date: 2008-05-22 11:29:40 -0700 (Thu, 22 May 2008)
New Revision: 12002
Added:
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.bgl
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.rang
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/bin/
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/go_mesher_solver_lsf_globe.bash
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/remap_lsf_machines.pl
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/run_lsf_globe_big.bash
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/constants.h
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/flags.guess
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/mpif.h
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/precision.h
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_missing_nodes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_410_650.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_cmb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_icb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_after_1.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_after_2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_before.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_inner_core_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_mantle_model.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/auto_ner.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/calc_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call1.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_mass_matrix_one_element.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_source_spectrum.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_source_time_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_arrays_source.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_coordinates_grid.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_element_properties.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/convolve_source_timefunction.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/count_number_of_sources.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_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_list_files_chunks.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_name_database.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/crustal_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/deallocate.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/define_derivation_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/define_superbrick.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/euler_angles.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_1D_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_cutplanes_eta.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_cutplanes_xi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_cmt.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_perm_cuthill_mckee.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_shape2D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_shape3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_value_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/gll_library.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/hex_nodes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/intgrl.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/jp3d1994_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/lagrange_poly.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/lgndr.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/make_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/make_gravity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/mantle_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/memory_eval.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_1066a.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_ak135.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_iasp91.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_jp1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_prem.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_ref.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_sea1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/netlib_specfun_erf.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_value_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/recompute_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/recompute_missing_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/reduce.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/rthetaphi_xyz.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/s362ani.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/save_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sea99_s_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sort_array_coordinates.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/spline_routines.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/store_xelm_yelm_zelm.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/stretching_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/topo_bathy.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.f90
Removed:
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_missing_nodes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_410_650.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_cmb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_icb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_1.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_before.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_inner_core_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_mantle_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_scalar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_vector.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/attenuation_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/auto_ner.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/calc_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call1.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_mass_matrix_one_element.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_spectrum.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_time_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_arrays_source.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_coordinates_grid.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_element_properties.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/constants.h
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/convolve_source_timefunction.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/count_number_of_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_central_cube_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_chunk_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_list_files_chunks.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_name_database.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_regions_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/crustal_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/deallocate.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/declar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_derivation_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_superbrick.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/euler_angles.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/exit_mpi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/flags.guess
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_1D_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_eta.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_xi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_cmt.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_event_info.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_perm_cuthill_mckee.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape2D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_value_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/gll_library.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/go_mesher_solver_lsf_globe.bash
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/hex_nodes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/intgrl.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/jp3d1994_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lagrange_poly.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lgndr.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_gravity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mantle_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/memory_eval.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/meshfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_1066a.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ak135.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_iasp91.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_jp1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_prem.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ref.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_sea1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mpif.h
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/netlib_specfun_erf.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/precision.h
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_value_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_missing_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/reduce.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/remap_lsf_machines.pl
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/rthetaphi_xyz.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/run_lsf_globe_big.bash
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/s362ani.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/save_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sea99_s_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sort_array_coordinates.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/specfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/spline_routines.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/store_xelm_yelm_zelm.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/stretching_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/topo_bathy.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/write_seismograms.f90
Modified:
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile
Log:
Changed directory structure and changed allocate deallocate statement for a few
files.
Laura
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile 2008-05-22 18:29:40 UTC (rev 12002)
@@ -56,12 +56,15 @@
MPILIBS =
FCFLAGS = #-g
-FCCOMPILE_CHECK = ${FC} ${FCFLAGS} $(FLAGS_CHECK)
-FCCOMPILE_NO_CHECK = ${FC} ${FCFLAGS} $(FLAGS_NO_CHECK)
-MPIFCCOMPILE_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_CHECK)
-MPIFCCOMPILE_NO_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK)
-MPIFCCOMPILE_NO_CHECK2 = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK2)
+SPECINC=setup/
+BIN=bin
+FCCOMPILE_CHECK = ${FC} ${FCFLAGS} $(FLAGS_CHECK) -I$(SPECINC)
+FCCOMPILE_NO_CHECK = ${FC} ${FCFLAGS} $(FLAGS_NO_CHECK) -I$(SPECINC)
+MPIFCCOMPILE_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_CHECK) -I$(SPECINC)
+MPIFCCOMPILE_NO_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK) -I$(SPECINC)
+MPIFCCOMPILE_NO_CHECK2 = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK2) -I$(SPECINC)
+
CC = gcc
CFLAGS = -g -O2
CPPFLAGS = -I.
@@ -71,7 +74,7 @@
RANLIB = ranlib
O = obj
-S = .
+S = src
libspecfem_a_OBJECTS = \
$O/add_missing_nodes.o \
@@ -194,19 +197,19 @@
XMESHFEM_OBJECTS = $O/meshfem3D.o $O/exit_mpi.o $(SOLVER_ARRAY_OBJECTS) $(LIBSPECFEM)
xmeshfem3D: $(XMESHFEM_OBJECTS)
## use MPI here
- ${MPIFCCOMPILE_CHECK} -o xmeshfem3D $(XMESHFEM_OBJECTS) $(MPILIBS)
+ ${MPIFCCOMPILE_CHECK} -o $(BIN)/xmeshfem3D $(XMESHFEM_OBJECTS) $(MPILIBS)
# solver also depends on values from mesher
XSPECFEM_OBJECTS = $(SOLVER_ARRAY_OBJECTS) $O/exit_mpi.o $(LIBSPECFEM)
xconvolve_source_timefunction: $O/convolve_source_timefunction.o
- ${FCCOMPILE_CHECK} -o xconvolve_source_timefunction $O/convolve_source_timefunction.o
+ ${FCCOMPILE_CHECK} -o $(BIN)/xconvolve_source_timefunction $O/convolve_source_timefunction.o
xcreate_header_file: $O/create_header_file.o $O/exit_mpi.o $O/get_value_parameters.o $O/read_compute_parameters.o $O/memory_eval.o $O/save_header_file.o $O/count_number_of_sources.o $O/read_value_parameters.o $O/euler_angles.o $O/reduce.o $O/rthetaphi_xyz.o $O/auto_ner.o
- ${MPIFCCOMPILE_CHECK} -o xcreate_header_file $O/create_header_file.o $O/exit_mpi.o $O/get_value_parameters.o $O/read_compute_parameters.o $O/memory_eval.o $O/save_header_file.o $O/count_number_of_sources.o $O/read_value_parameters.o $O/euler_angles.o $O/reduce.o $O/rthetaphi_xyz.o $O/auto_ner.o
+ ${MPIFCCOMPILE_CHECK} -o $(BIN)/xcreate_header_file $O/create_header_file.o $O/exit_mpi.o $O/get_value_parameters.o $O/read_compute_parameters.o $O/memory_eval.o $O/save_header_file.o $O/count_number_of_sources.o $O/read_value_parameters.o $O/euler_angles.o $O/reduce.o $O/rthetaphi_xyz.o $O/auto_ner.o
clean:
- rm -f $O/* *.o work.pc* *.mod xmeshfem3D xconvolve_source_timefunction xcreate_header_file PI*
+ rm -f $O/* *.o work.pc* *.mod $(BIN)/xmeshfem3D $(BIN)/xconvolve_source_timefunction $(BIN)/xcreate_header_file PI*
###
@@ -226,27 +229,27 @@
### optimized flags and dependence on values from mesher here
###
-$O/specfem3D.o: constants.h OUTPUT_FILES/values_from_mesher.h $S/specfem3D.f90
+$O/specfem3D.o: $(SPECINC)/constants.h OUTPUT_FILES/values_from_mesher.h $S/specfem3D.f90
${MPIFCCOMPILE_NO_CHECK2} -c -o $O/specfem3D.o ${FCFLAGS_f90} $S/specfem3D.f90
-$O/compute_forces_crust_mantle.o: constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_crust_mantle.f90
+$O/compute_forces_crust_mantle.o: $(SPECINC)/constants.h OUTPUT_FILES/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
-$O/compute_forces_outer_core.o: constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_outer_core.f90
+$O/compute_forces_outer_core.o: $(SPECINC)/constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_outer_core.f90
${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_outer_core.o ${FCFLAGS_f90} $S/compute_forces_outer_core.f90
-$O/compute_forces_inner_core.o: constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_inner_core.f90
+$O/compute_forces_inner_core.o: $(SPECINC)/constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_inner_core.f90
${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: constants.h $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: constants.h $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: constants.h OUTPUT_FILES/values_from_mesher.h $S/assemble_MPI_central_cube.f90
+$O/assemble_MPI_central_cube.o: $(SPECINC)/constants.h OUTPUT_FILES/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
###
@@ -263,236 +266,236 @@
${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: constants.h $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: constants.h $S/sort_array_coordinates.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: constants.h $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: constants.h $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: constants.h $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: constants.h $S/count_number_of_sources.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
-$O/read_value_parameters.o: constants.h $S/read_value_parameters.f90
+$O/read_value_parameters.o: $(SPECINC)/constants.h $S/read_value_parameters.f90
${FCCOMPILE_CHECK} -c -o $O/read_value_parameters.o ${FCFLAGS_f90} $S/read_value_parameters.f90
-$O/get_value_parameters.o: constants.h $S/get_value_parameters.f90
+$O/get_value_parameters.o: $(SPECINC)/constants.h $S/get_value_parameters.f90
${FCCOMPILE_CHECK} -c -o $O/get_value_parameters.o ${FCFLAGS_f90} $S/get_value_parameters.f90
-$O/topo_bathy.o: constants.h $S/topo_bathy.f90
+$O/topo_bathy.o: $(SPECINC)/constants.h $S/topo_bathy.f90
${FCCOMPILE_CHECK} -c -o $O/topo_bathy.o ${FCFLAGS_f90} $S/topo_bathy.f90
-$O/calc_jacobian.o: constants.h $S/calc_jacobian.f90
+$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/crustal_model.o: constants.h $S/crustal_model.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
-$O/make_ellipticity.o: constants.h $S/make_ellipticity.f90
+$O/make_ellipticity.o: $(SPECINC)/constants.h $S/make_ellipticity.f90
${FCCOMPILE_CHECK} -c -o $O/make_ellipticity.o ${FCFLAGS_f90} $S/make_ellipticity.f90
-$O/get_jacobian_boundaries.o: constants.h $S/get_jacobian_boundaries.f90
+$O/get_jacobian_boundaries.o: $(SPECINC)/constants.h $S/get_jacobian_boundaries.f90
${FCCOMPILE_CHECK} -c -o $O/get_jacobian_boundaries.o ${FCFLAGS_f90} $S/get_jacobian_boundaries.f90
-$O/get_MPI_cutplanes_xi.o: constants.h $S/get_MPI_cutplanes_xi.f90
+$O/get_MPI_cutplanes_xi.o: $(SPECINC)/constants.h $S/get_MPI_cutplanes_xi.f90
${FCCOMPILE_CHECK} -c -o $O/get_MPI_cutplanes_xi.o ${FCFLAGS_f90} $S/get_MPI_cutplanes_xi.f90
-$O/get_MPI_cutplanes_eta.o: constants.h $S/get_MPI_cutplanes_eta.f90
+$O/get_MPI_cutplanes_eta.o: $(SPECINC)/constants.h $S/get_MPI_cutplanes_eta.f90
${FCCOMPILE_CHECK} -c -o $O/get_MPI_cutplanes_eta.o ${FCFLAGS_f90} $S/get_MPI_cutplanes_eta.f90
-$O/get_MPI_1D_buffers.o: constants.h $S/get_MPI_1D_buffers.f90
+$O/get_MPI_1D_buffers.o: $(SPECINC)/constants.h $S/get_MPI_1D_buffers.f90
${FCCOMPILE_CHECK} -c -o $O/get_MPI_1D_buffers.o ${FCFLAGS_f90} $S/get_MPI_1D_buffers.f90
-$O/get_cmt.o: constants.h $S/get_cmt.f90
+$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: constants.h $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: constants.h $S/get_ellipticity.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
-$O/get_global.o: constants.h $S/get_global.f90
+$O/get_global.o: $(SPECINC)/constants.h $S/get_global.f90
${FCCOMPILE_CHECK} -c -o $O/get_global.o ${FCFLAGS_f90} $S/get_global.f90
-$O/make_gravity.o: constants.h $S/make_gravity.f90
+$O/make_gravity.o: $(SPECINC)/constants.h $S/make_gravity.f90
${FCCOMPILE_CHECK} -c -o $O/make_gravity.o ${FCFLAGS_f90} $S/make_gravity.f90
-$O/rthetaphi_xyz.o: constants.h $S/rthetaphi_xyz.f90
+$O/rthetaphi_xyz.o: $(SPECINC)/constants.h $S/rthetaphi_xyz.f90
${FCCOMPILE_CHECK} -c -o $O/rthetaphi_xyz.o ${FCFLAGS_f90} $S/rthetaphi_xyz.f90
-$O/get_model.o: constants.h $S/get_model.f90
+$O/get_model.o: $(SPECINC)/constants.h $S/get_model.f90
${FCCOMPILE_CHECK} -c -o $O/get_model.o ${FCFLAGS_f90} $S/get_model.f90
-$O/get_shape3D.o: constants.h $S/get_shape3D.f90
+$O/get_shape3D.o: $(SPECINC)/constants.h $S/get_shape3D.f90
${FCCOMPILE_CHECK} -c -o $O/get_shape3D.o ${FCFLAGS_f90} $S/get_shape3D.f90
-$O/get_shape2D.o: constants.h $S/get_shape2D.f90
+$O/get_shape2D.o: $(SPECINC)/constants.h $S/get_shape2D.f90
${FCCOMPILE_CHECK} -c -o $O/get_shape2D.o ${FCFLAGS_f90} $S/get_shape2D.f90
-$O/hex_nodes.o: constants.h $S/hex_nodes.f90
+$O/hex_nodes.o: $(SPECINC)/constants.h $S/hex_nodes.f90
${FCCOMPILE_CHECK} -c -o $O/hex_nodes.o ${FCFLAGS_f90} $S/hex_nodes.f90
-$O/intgrl.o: constants.h $S/intgrl.f90
+$O/intgrl.o: $(SPECINC)/constants.h $S/intgrl.f90
${FCCOMPILE_CHECK} -c -o $O/intgrl.o ${FCFLAGS_f90} $S/intgrl.f90
-$O/mantle_model.o: constants.h $S/mantle_model.f90
+$O/mantle_model.o: $(SPECINC)/constants.h $S/mantle_model.f90
${FCCOMPILE_CHECK} -c -o $O/mantle_model.o ${FCFLAGS_f90} $S/mantle_model.f90
-$O/jp3d1994_model.o: constants.h $S/jp3d1994_model.f90
+$O/jp3d1994_model.o: $(SPECINC)/constants.h $S/jp3d1994_model.f90
${FCCOMPILE_CHECK} -c -o $O/jp3d1994_model.o ${FCFLAGS_f90} $S/jp3d1994_model.f90
-$O/sea99_s_model.o: constants.h $S/sea99_s_model.f90
+$O/sea99_s_model.o: $(SPECINC)/constants.h $S/sea99_s_model.f90
${FCCOMPILE_CHECK} -c -o $O/sea99_s_model.o ${FCFLAGS_f90} $S/sea99_s_model.f90
-$O/euler_angles.o: constants.h $S/euler_angles.f90
+$O/euler_angles.o: $(SPECINC)/constants.h $S/euler_angles.f90
${FCCOMPILE_CHECK} -c -o $O/euler_angles.o ${FCFLAGS_f90} $S/euler_angles.f90
## use MPI here
-$O/meshfem3D.o: constants.h $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: constants.h $S/spline_routines.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
-$O/create_list_files_chunks.o: constants.h $S/create_list_files_chunks.f90
+$O/create_list_files_chunks.o: $(SPECINC)/constants.h $S/create_list_files_chunks.f90
${FCCOMPILE_CHECK} -c -o $O/create_list_files_chunks.o ${FCFLAGS_f90} $S/create_list_files_chunks.f90
-$O/recompute_missing_arrays.o: constants.h $S/recompute_missing_arrays.f90
+$O/recompute_missing_arrays.o: $(SPECINC)/constants.h $S/recompute_missing_arrays.f90
${FCCOMPILE_CHECK} -c -o $O/recompute_missing_arrays.o ${FCFLAGS_f90} $S/recompute_missing_arrays.f90
$O/netlib_specfun_erf.o: $S/netlib_specfun_erf.f90
${FCCOMPILE_CHECK} -c -o $O/netlib_specfun_erf.o ${FCFLAGS_f90} $S/netlib_specfun_erf.f90
-$O/lgndr.o: constants.h $S/lgndr.f90
+$O/lgndr.o: $(SPECINC)/constants.h $S/lgndr.f90
${FCCOMPILE_CHECK} -c -o $O/lgndr.o ${FCFLAGS_f90} $S/lgndr.f90
-$O/model_prem.o: constants.h $S/model_prem.f90
+$O/model_prem.o: $(SPECINC)/constants.h $S/model_prem.f90
${FCCOMPILE_CHECK} -c -o $O/model_prem.o ${FCFLAGS_f90} $S/model_prem.f90
-$O/model_iasp91.o: constants.h $S/model_iasp91.f90
+$O/model_iasp91.o: $(SPECINC)/constants.h $S/model_iasp91.f90
${FCCOMPILE_CHECK} -c -o $O/model_iasp91.o ${FCFLAGS_f90} $S/model_iasp91.f90
-$O/model_1066a.o: constants.h $S/model_1066a.f90
+$O/model_1066a.o: $(SPECINC)/constants.h $S/model_1066a.f90
${FCCOMPILE_CHECK} -c -o $O/model_1066a.o ${FCFLAGS_f90} $S/model_1066a.f90
-$O/model_ak135.o: constants.h $S/model_ak135.f90
+$O/model_ak135.o: $(SPECINC)/constants.h $S/model_ak135.f90
${FCCOMPILE_CHECK} -c -o $O/model_ak135.o ${FCFLAGS_f90} $S/model_ak135.f90
-$O/model_ref.o: constants.h $S/model_ref.f90
+$O/model_ref.o: $(SPECINC)/constants.h $S/model_ref.f90
${FCCOMPILE_CHECK} -c -o $O/model_ref.o ${FCFLAGS_f90} $S/model_ref.f90
-$O/model_jp1d.o: constants.h $S/model_jp1d.f90
+$O/model_jp1d.o: $(SPECINC)/constants.h $S/model_jp1d.f90
${FCCOMPILE_CHECK} -c -o $O/model_jp1d.o ${FCFLAGS_f90} $S/model_jp1d.f90
-$O/model_sea1d.o: constants.h $S/model_sea1d.f90
+$O/model_sea1d.o: $(SPECINC)/constants.h $S/model_sea1d.f90
${FCCOMPILE_CHECK} -c -o $O/model_sea1d.o ${FCFLAGS_f90} $S/model_sea1d.f90
-$O/anisotropic_mantle_model.o: constants.h $S/anisotropic_mantle_model.f90
+$O/anisotropic_mantle_model.o: $(SPECINC)/constants.h $S/anisotropic_mantle_model.f90
${FCCOMPILE_CHECK} -c -o $O/anisotropic_mantle_model.o ${FCFLAGS_f90} $S/anisotropic_mantle_model.f90
-$O/anisotropic_inner_core_model.o: constants.h $S/anisotropic_inner_core_model.f90
+$O/anisotropic_inner_core_model.o: $(SPECINC)/constants.h $S/anisotropic_inner_core_model.f90
${FCCOMPILE_CHECK} -c -o $O/anisotropic_inner_core_model.o ${FCFLAGS_f90} $S/anisotropic_inner_core_model.f90
-$O/reduce.o: constants.h $S/reduce.f90
+$O/reduce.o: $(SPECINC)/constants.h $S/reduce.f90
${FCCOMPILE_CHECK} -c -o $O/reduce.o ${FCFLAGS_f90} $S/reduce.f90
-$O/save_header_file.o: constants.h $S/save_header_file.f90
+$O/save_header_file.o: $(SPECINC)/constants.h $S/save_header_file.f90
${FCCOMPILE_CHECK} -c -o $O/save_header_file.o ${FCFLAGS_f90} $S/save_header_file.f90
-$O/comp_source_spectrum.o: constants.h $S/comp_source_spectrum.f90
+$O/comp_source_spectrum.o: $(SPECINC)/constants.h $S/comp_source_spectrum.f90
${FCCOMPILE_CHECK} -c -o $O/comp_source_spectrum.o ${FCFLAGS_f90} $S/comp_source_spectrum.f90
-$O/add_topography.o: constants.h $S/add_topography.f90
+$O/add_topography.o: $(SPECINC)/constants.h $S/add_topography.f90
${FCCOMPILE_CHECK} -c -o $O/add_topography.o ${FCFLAGS_f90} $S/add_topography.f90
-$O/moho_stretching.o: constants.h $S/moho_stretching.f90
+$O/moho_stretching.o: $(SPECINC)/constants.h $S/moho_stretching.f90
${FCCOMPILE_CHECK} -c -o $O/moho_stretching.o ${FCFLAGS_f90} $S/moho_stretching.f90
-$O/add_topography_410_650.o: constants.h $S/add_topography_410_650.f90
+$O/add_topography_410_650.o: $(SPECINC)/constants.h $S/add_topography_410_650.f90
${FCCOMPILE_CHECK} -c -o $O/add_topography_410_650.o ${FCFLAGS_f90} $S/add_topography_410_650.f90
-$O/add_topography_cmb.o: constants.h $S/add_topography_cmb.f90
+$O/add_topography_cmb.o: $(SPECINC)/constants.h $S/add_topography_cmb.f90
${FCCOMPILE_CHECK} -c -o $O/add_topography_cmb.o ${FCFLAGS_f90} $S/add_topography_cmb.f90
-$O/add_topography_icb.o: constants.h $S/add_topography_icb.f90
+$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: constants.h $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: constants.h $S/lagrange_poly.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
-$O/recompute_jacobian.o: constants.h $S/recompute_jacobian.f90
+$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: constants.h $S/create_regions_mesh.f90
+$O/create_regions_mesh.o: $(SPECINC)/constants.h $S/create_regions_mesh.f90
${FCCOMPILE_CHECK} -c -o $O/create_regions_mesh.o ${FCFLAGS_f90} $S/create_regions_mesh.f90
-$O/create_name_database.o: constants.h $S/create_name_database.f90
+$O/create_name_database.o: $(SPECINC)/constants.h $S/create_name_database.f90
${FCCOMPILE_CHECK} -c -o $O/create_name_database.o ${FCFLAGS_f90} $S/create_name_database.f90
-$O/get_perm_cuthill_mckee.o: constants.h $S/get_perm_cuthill_mckee.f90
+$O/get_perm_cuthill_mckee.o: $(SPECINC)/constants.h $S/get_perm_cuthill_mckee.f90
${FCCOMPILE_CHECK} -c -o $O/get_perm_cuthill_mckee.o ${FCFLAGS_f90} $S/get_perm_cuthill_mckee.f90
-$O/define_derivation_matrices.o: constants.h $S/define_derivation_matrices.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
-$O/compute_arrays_source.o: constants.h $S/compute_arrays_source.f90
+$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: constants.h $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: constants.h $S/attenuation_model.f90 $O/model_ak135.o $O/model_1066a.o $O/model_ref.o
+$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: constants.h $S/gll_library.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
-$O/add_missing_nodes.o: constants.h $S/add_missing_nodes.f90
+$O/add_missing_nodes.o: $(SPECINC)/constants.h $S/add_missing_nodes.f90
${FCCOMPILE_CHECK} -c -o $O/add_missing_nodes.o ${FCFLAGS_f90} $S/add_missing_nodes.f90
-$O/compute_coordinates_grid.o: constants.h $S/compute_coordinates_grid.f90
+$O/compute_coordinates_grid.o: $(SPECINC)/constants.h $S/compute_coordinates_grid.f90
${FCCOMPILE_CHECK} -c -o $O/compute_coordinates_grid.o ${FCFLAGS_f90} $S/compute_coordinates_grid.f90
-$O/compute_element_properties.o: constants.h $S/compute_element_properties.f90
+$O/compute_element_properties.o: $(SPECINC)/constants.h $S/compute_element_properties.f90
${FCCOMPILE_CHECK} -c -o $O/compute_element_properties.o ${FCFLAGS_f90} $S/compute_element_properties.f90
-$O/define_superbrick.o: constants.h $S/define_superbrick.f90
+$O/define_superbrick.o: $(SPECINC)/constants.h $S/define_superbrick.f90
${FCCOMPILE_CHECK} -c -o $O/define_superbrick.o ${FCFLAGS_f90} $S/define_superbrick.f90
-$O/stretching_function.o: constants.h $S/stretching_function.f90
+$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: constants.h $S/read_compute_parameters.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/auto_ner.o: constants.h $S/auto_ner.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
-$O/memory_eval.o: constants.h $S/memory_eval.f90
+$O/memory_eval.o: $(SPECINC)/constants.h $S/memory_eval.f90
${FCCOMPILE_CHECK} -c -o $O/memory_eval.o ${FCFLAGS_f90} $S/memory_eval.f90
-$O/s362ani.o: constants.h $S/s362ani.f90
+$O/s362ani.o: $(SPECINC)/constants.h $S/s362ani.f90
${FCCOMPILE_CHECK} -c -o $O/s362ani.o ${FCFLAGS_f90} $S/s362ani.f90
###
### rule for the header file
###
-OUTPUT_FILES/values_from_mesher.h: xcreate_header_file
+OUTPUT_FILES/values_from_mesher.h: $(BIN)/xcreate_header_file
mkdir -p OUTPUT_FILES
- ./xcreate_header_file
+ $(BIN)/xcreate_header_file
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.bgl
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.bgl (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.bgl 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,482 @@
+#=====================================================================
+#
+# S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+# --------------------------------------------------
+#
+# 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
+# February 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.
+#
+#=====================================================================
+
+# Makefile. Generated from Makefile.in by configure.
+
+FC = mpxlf90 -qmaxmem=-1 -qxflag=stacksize
+FCFLAGS = #-g
+MPIFC = mpxlf90 -qmaxmem=-1 -qxflag=stacksize
+MPILIBS =
+FLAGS_NO_CHECK = -O3 -qsave -qstrict -qarch=440 -qtune=440 -qfree=f90 -Q -qsuffix=f=f90
+FLAGS_CHECK = $(FLAGS_NO_CHECK)
+FCFLAGS_f90 =
+
+CC = mpcc -I$(SPECINC)
+CFLAGS = -g
+CPPFLAGS = -g -O3 -qarch=440 -qtune=440
+
+AR = ar
+ARFLAGS = -c -r -u ## -elf64-x86-64
+RANLIB = ranlib
+
+FLAGS_NO_CHECK2 = $(FLAGS_NO_CHECK)
+
+SPECINC = setup/
+BIN = bin
+
+FCCOMPILE_CHECK = ${FC} ${FCFLAGS} $(FLAGS_CHECK) -I$(SPECINC)
+FCCOMPILE_NO_CHECK = ${FC} ${FCFLAGS} $(FLAGS_NO_CHECK) -I$(SPECINC)
+MPIFCCOMPILE_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_CHECK) -I$(SPECINC)
+MPIFCCOMPILE_NO_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK) -I$(SPECINC)
+MPIFCCOMPILE_NO_CHECK2 = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK2) -I$(SPECINC)
+
+
+O = obj
+S = src
+
+libspecfem_a_OBJECTS = \
+ $O/add_missing_nodes.o \
+ $O/add_topography.o \
+ $O/add_topography_410_650.o \
+ $O/add_topography_cmb.o \
+ $O/add_topography_icb.o \
+ $O/anisotropic_inner_core_model.o \
+ $O/anisotropic_mantle_model.o \
+ $O/assemble_MPI_scalar.o \
+ $O/assemble_MPI_vector.o \
+ $O/attenuation_model.o \
+ $O/calc_jacobian.o \
+ $O/comp_source_spectrum.o \
+ $O/comp_source_time_function.o \
+ $O/compute_arrays_source.o \
+ $O/compute_coordinates_grid.o \
+ $O/compute_element_properties.o \
+ $O/count_number_of_sources.o \
+ $O/create_central_cube_buffers.o \
+ $O/create_chunk_buffers.o \
+ $O/create_header_file.o \
+ $O/create_name_database.o \
+ $O/create_regions_mesh.o \
+ $O/crustal_model.o \
+ $O/define_derivation_matrices.o \
+ $O/define_superbrick.o \
+ $O/euler_angles.o \
+ $O/get_MPI_1D_buffers.o \
+ $O/get_MPI_cutplanes_eta.o \
+ $O/get_MPI_cutplanes_xi.o \
+ $O/get_cmt.o \
+ $O/get_ellipticity.o \
+ $O/get_event_info.o \
+ $O/get_global.o \
+ $O/get_jacobian_boundaries.o \
+ $O/get_model.o \
+ $O/get_perm_cuthill_mckee.o \
+ $O/get_shape2D.o \
+ $O/get_shape3D.o \
+ $O/get_value_parameters.o \
+ $O/gll_library.o \
+ $O/hex_nodes.o \
+ $O/intgrl.o \
+ $O/lagrange_poly.o \
+ $O/lgndr.o \
+ $O/locate_receivers.o \
+ $O/locate_sources.o \
+ $O/make_ellipticity.o \
+ $O/make_gravity.o \
+ $O/mantle_model.o \
+ $O/jp3d1994_model.o \
+ $O/sea99_s_model.o \
+ $O/memory_eval.o \
+ $O/model_1066a.o \
+ $O/model_ak135.o \
+ $O/model_iasp91.o \
+ $O/model_prem.o \
+ $O/model_ref.o \
+ $O/model_jp1d.o \
+ $O/model_sea1d.o \
+ $O/moho_stretching.o \
+ $O/spline_routines.o \
+ $O/create_list_files_chunks.o \
+ $O/recompute_missing_arrays.o \
+ $O/netlib_specfun_erf.o \
+ $O/read_compute_parameters.o \
+ $O/read_value_parameters.o \
+ $O/auto_ner.o \
+ $O/recompute_jacobian.o \
+ $O/reduce.o \
+ $O/rthetaphi_xyz.o \
+ $O/s362ani.o \
+ $O/save_header_file.o \
+ $O/sort_array_coordinates.o \
+ $O/stretching_function.o \
+ $O/topo_bathy.o \
+ $O/write_seismograms.o \
+ $(EMPTY_MACRO)
+
+# solver objects with statically allocated arrays; dependent upon
+# values_from_mesher.h
+SOLVER_ARRAY_OBJECTS = \
+ $O/assemble_MPI_central_cube.o \
+ $O/compute_forces_crust_mantle.o \
+ $O/compute_forces_inner_core.o \
+ $O/compute_forces_outer_core.o \
+ $O/specfem3D.o \
+ $(EMPTY_MACRO)
+
+LIBSPECFEM = $O/libspecfem.a
+
+
+####
+#### targets
+####
+
+# default targets
+DEFAULT = \
+ OUTPUT_FILES/values_from_mesher.h \
+ xmeshfem3D \
+ $(EMPTY_MACRO)
+
+default: $(DEFAULT)
+
+all: clean default
+
+backup:
+ cp *f90 *h README_SPECFEM3D_GLOBE DATA/Par_file* Makefile go_mesher go_solver mymachines bak
+
+bak: backup
+
+
+####
+#### rules for executables
+####
+
+# rules for the main programs
+XMESHFEM_OBJECTS = $O/meshfem3D.o $O/exit_mpi.o $(SOLVER_ARRAY_OBJECTS) $(LIBSPECFEM)
+xmeshfem3D: $(XMESHFEM_OBJECTS)
+## use MPI here
+ ${MPIFCCOMPILE_CHECK} -o $(BIN)/xmeshfem3D $(XMESHFEM_OBJECTS) $(MPILIBS)
+
+# solver also depends on values from mesher
+XSPECFEM_OBJECTS = $(SOLVER_ARRAY_OBJECTS) $O/exit_mpi.o $(LIBSPECFEM)
+
+xconvolve_source_timefunction: $O/convolve_source_timefunction.o
+ ${FCCOMPILE_CHECK} -o xconvolve_source_timefunction $O/convolve_source_timefunction.o
+
+xcreate_header_file: $O/create_header_file.o $O/exit_mpi.o $O/get_value_parameters.o $O/read_compute_parameters.o $O/memory_eval.o $O/save_header_file.o $O/count_number_of_sources.o $O/read_value_parameters.o $O/euler_angles.o $O/reduce.o $O/rthetaphi_xyz.o $O/auto_ner.o
+ ${MPIFCCOMPILE_CHECK} -o $(BIN)/xcreate_header_file $O/create_header_file.o $O/exit_mpi.o $O/get_value_parameters.o $O/read_compute_parameters.o $O/memory_eval.o $O/save_header_file.o $O/count_number_of_sources.o $O/read_value_parameters.o $O/euler_angles.o $O/reduce.o $O/rthetaphi_xyz.o $O/auto_ner.o
+
+clean:
+ rm -f $O/* *.o work.pc* *.mod $(BIN)/xmeshfem3D $(BIN)/xconvolve_source_timefunction $(BIN)/xcreate_header_file PI*
+
+
+###
+### rule for the archive library
+###
+
+$O/libspecfem.a: $(libspecfem_a_OBJECTS)
+ -rm -f $O/libspecfem.a
+ $(AR) $(ARFLAGS) $O/libspecfem.a $(libspecfem_a_OBJECTS)
+ $(RANLIB) $O/libspecfem.a
+
+####
+#### rule for each .o file below
+####
+
+###
+### optimized flags and dependence on values from mesher here
+###
+
+$O/specfem3D.o: $(SPECINC)/constants.h OUTPUT_FILES/values_from_mesher.h $S/specfem3D.f90
+ ${MPIFCCOMPILE_NO_CHECK2} -c -o $O/specfem3D.o ${FCFLAGS_f90} $S/specfem3D.f90
+
+$O/compute_forces_crust_mantle.o: $(SPECINC)/constants.h OUTPUT_FILES/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
+
+$O/compute_forces_outer_core.o: $(SPECINC)/constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_outer_core.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_outer_core.o ${FCFLAGS_f90} $S/compute_forces_outer_core.f90
+
+$O/compute_forces_inner_core.o: $(SPECINC)/constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_inner_core.f90
+ ${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
+
+### 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_central_cube.o: $(SPECINC)/constants.h OUTPUT_FILES/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
+###
+
+$O/convolve_source_timefunction.o: $S/convolve_source_timefunction.f90
+ ${FCCOMPILE_CHECK} -c -o $O/convolve_source_timefunction.o ${FCFLAGS_f90} $S/convolve_source_timefunction.f90
+
+$O/create_header_file.o: $S/create_header_file.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_header_file.o ${FCFLAGS_f90} $S/create_header_file.f90
+
+$O/comp_source_time_function.o: $S/comp_source_time_function.f90
+ ${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/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
+
+### 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
+
+## 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/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
+
+$O/read_value_parameters.o: $(SPECINC)/constants.h $S/read_value_parameters.f90
+ ${FCCOMPILE_CHECK} -c -o $O/read_value_parameters.o ${FCFLAGS_f90} $S/read_value_parameters.f90
+
+$O/get_value_parameters.o: $(SPECINC)/constants.h $S/get_value_parameters.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_value_parameters.o ${FCFLAGS_f90} $S/get_value_parameters.f90
+
+$O/topo_bathy.o: $(SPECINC)/constants.h $S/topo_bathy.f90
+ ${FCCOMPILE_CHECK} -c -o $O/topo_bathy.o ${FCFLAGS_f90} $S/topo_bathy.f90
+
+$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/crustal_model.o: $(SPECINC)/constants.h $S/crustal_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/crustal_model.o ${FCFLAGS_f90} $S/crustal_model.f90
+
+$O/make_ellipticity.o: $(SPECINC)/constants.h $S/make_ellipticity.f90
+ ${FCCOMPILE_CHECK} -c -o $O/make_ellipticity.o ${FCFLAGS_f90} $S/make_ellipticity.f90
+
+$O/get_jacobian_boundaries.o: $(SPECINC)/constants.h $S/get_jacobian_boundaries.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_jacobian_boundaries.o ${FCFLAGS_f90} $S/get_jacobian_boundaries.f90
+
+$O/get_MPI_cutplanes_xi.o: $(SPECINC)/constants.h $S/get_MPI_cutplanes_xi.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_MPI_cutplanes_xi.o ${FCFLAGS_f90} $S/get_MPI_cutplanes_xi.f90
+
+$O/get_MPI_cutplanes_eta.o: $(SPECINC)/constants.h $S/get_MPI_cutplanes_eta.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_MPI_cutplanes_eta.o ${FCFLAGS_f90} $S/get_MPI_cutplanes_eta.f90
+
+$O/get_MPI_1D_buffers.o: $(SPECINC)/constants.h $S/get_MPI_1D_buffers.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_MPI_1D_buffers.o ${FCFLAGS_f90} $S/get_MPI_1D_buffers.f90
+
+$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_ellipticity.o: $(SPECINC)/constants.h $S/get_ellipticity.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_ellipticity.o ${FCFLAGS_f90} $S/get_ellipticity.f90
+
+$O/get_global.o: $(SPECINC)/constants.h $S/get_global.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_global.o ${FCFLAGS_f90} $S/get_global.f90
+
+$O/make_gravity.o: $(SPECINC)/constants.h $S/make_gravity.f90
+ ${FCCOMPILE_CHECK} -c -o $O/make_gravity.o ${FCFLAGS_f90} $S/make_gravity.f90
+
+$O/rthetaphi_xyz.o: $(SPECINC)/constants.h $S/rthetaphi_xyz.f90
+ ${FCCOMPILE_CHECK} -c -o $O/rthetaphi_xyz.o ${FCFLAGS_f90} $S/rthetaphi_xyz.f90
+
+$O/get_model.o: $(SPECINC)/constants.h $S/get_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_model.o ${FCFLAGS_f90} $S/get_model.f90
+
+$O/get_shape3D.o: $(SPECINC)/constants.h $S/get_shape3D.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_shape3D.o ${FCFLAGS_f90} $S/get_shape3D.f90
+
+$O/get_shape2D.o: $(SPECINC)/constants.h $S/get_shape2D.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_shape2D.o ${FCFLAGS_f90} $S/get_shape2D.f90
+
+$O/hex_nodes.o: $(SPECINC)/constants.h $S/hex_nodes.f90
+ ${FCCOMPILE_CHECK} -c -o $O/hex_nodes.o ${FCFLAGS_f90} $S/hex_nodes.f90
+
+$O/intgrl.o: $(SPECINC)/constants.h $S/intgrl.f90
+ ${FCCOMPILE_CHECK} -c -o $O/intgrl.o ${FCFLAGS_f90} $S/intgrl.f90
+
+$O/mantle_model.o: $(SPECINC)/constants.h $S/mantle_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/mantle_model.o ${FCFLAGS_f90} $S/mantle_model.f90
+
+$O/jp3d1994_model.o: $(SPECINC)/constants.h $S/jp3d1994_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/jp3d1994_model.o ${FCFLAGS_f90} $S/jp3d1994_model.f90
+
+$O/sea99_s_model.o: $(SPECINC)/constants.h $S/sea99_s_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/sea99_s_model.o ${FCFLAGS_f90} $S/sea99_s_model.f90
+
+$O/euler_angles.o: $(SPECINC)/constants.h $S/euler_angles.f90
+ ${FCCOMPILE_CHECK} -c -o $O/euler_angles.o ${FCFLAGS_f90} $S/euler_angles.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/spline_routines.o: $(SPECINC)/constants.h $S/spline_routines.f90
+ ${FCCOMPILE_CHECK} -c -o $O/spline_routines.o ${FCFLAGS_f90} $S/spline_routines.f90
+
+$O/create_list_files_chunks.o: $(SPECINC)/constants.h $S/create_list_files_chunks.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_list_files_chunks.o ${FCFLAGS_f90} $S/create_list_files_chunks.f90
+
+$O/recompute_missing_arrays.o: $(SPECINC)/constants.h $S/recompute_missing_arrays.f90
+ ${FCCOMPILE_CHECK} -c -o $O/recompute_missing_arrays.o ${FCFLAGS_f90} $S/recompute_missing_arrays.f90
+
+$O/netlib_specfun_erf.o: $S/netlib_specfun_erf.f90
+ ${FCCOMPILE_CHECK} -c -o $O/netlib_specfun_erf.o ${FCFLAGS_f90} $S/netlib_specfun_erf.f90
+
+$O/lgndr.o: $(SPECINC)/constants.h $S/lgndr.f90
+ ${FCCOMPILE_CHECK} -c -o $O/lgndr.o ${FCFLAGS_f90} $S/lgndr.f90
+
+$O/model_prem.o: $(SPECINC)/constants.h $S/model_prem.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_prem.o ${FCFLAGS_f90} $S/model_prem.f90
+
+$O/model_iasp91.o: $(SPECINC)/constants.h $S/model_iasp91.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_iasp91.o ${FCFLAGS_f90} $S/model_iasp91.f90
+
+$O/model_1066a.o: $(SPECINC)/constants.h $S/model_1066a.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_1066a.o ${FCFLAGS_f90} $S/model_1066a.f90
+
+$O/model_ak135.o: $(SPECINC)/constants.h $S/model_ak135.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_ak135.o ${FCFLAGS_f90} $S/model_ak135.f90
+
+$O/model_ref.o: $(SPECINC)/constants.h $S/model_ref.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_ref.o ${FCFLAGS_f90} $S/model_ref.f90
+
+$O/model_jp1d.o: $(SPECINC)/constants.h $S/model_jp1d.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_jp1d.o ${FCFLAGS_f90} $S/model_jp1d.f90
+
+$O/model_sea1d.o: $(SPECINC)/constants.h $S/model_sea1d.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_sea1d.o ${FCFLAGS_f90} $S/model_sea1d.f90
+
+$O/anisotropic_mantle_model.o: $(SPECINC)/constants.h $S/anisotropic_mantle_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/anisotropic_mantle_model.o ${FCFLAGS_f90} $S/anisotropic_mantle_model.f90
+
+$O/anisotropic_inner_core_model.o: $(SPECINC)/constants.h $S/anisotropic_inner_core_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/anisotropic_inner_core_model.o ${FCFLAGS_f90} $S/anisotropic_inner_core_model.f90
+
+$O/reduce.o: $(SPECINC)/constants.h $S/reduce.f90
+ ${FCCOMPILE_CHECK} -c -o $O/reduce.o ${FCFLAGS_f90} $S/reduce.f90
+
+$O/save_header_file.o: $(SPECINC)/constants.h $S/save_header_file.f90
+ ${FCCOMPILE_CHECK} -c -o $O/save_header_file.o ${FCFLAGS_f90} $S/save_header_file.f90
+
+$O/comp_source_spectrum.o: $(SPECINC)/constants.h $S/comp_source_spectrum.f90
+ ${FCCOMPILE_CHECK} -c -o $O/comp_source_spectrum.o ${FCFLAGS_f90} $S/comp_source_spectrum.f90
+
+$O/add_topography.o: $(SPECINC)/constants.h $S/add_topography.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_topography.o ${FCFLAGS_f90} $S/add_topography.f90
+
+$O/moho_stretching.o: $(SPECINC)/constants.h $S/moho_stretching.f90
+ ${FCCOMPILE_CHECK} -c -o $O/moho_stretching.o ${FCFLAGS_f90} $S/moho_stretching.f90
+
+$O/add_topography_410_650.o: $(SPECINC)/constants.h $S/add_topography_410_650.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_topography_410_650.o ${FCFLAGS_f90} $S/add_topography_410_650.f90
+
+$O/add_topography_cmb.o: $(SPECINC)/constants.h $S/add_topography_cmb.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_topography_cmb.o ${FCFLAGS_f90} $S/add_topography_cmb.f90
+
+$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/lagrange_poly.o: $(SPECINC)/constants.h $S/lagrange_poly.f90
+ ${FCCOMPILE_CHECK} -c -o $O/lagrange_poly.o ${FCFLAGS_f90} $S/lagrange_poly.f90
+
+$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
+ ${FCCOMPILE_CHECK} -c -o $O/create_regions_mesh.o ${FCFLAGS_f90} $S/create_regions_mesh.f90
+
+$O/create_name_database.o: $(SPECINC)/constants.h $S/create_name_database.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_name_database.o ${FCFLAGS_f90} $S/create_name_database.f90
+
+$O/get_perm_cuthill_mckee.o: $(SPECINC)/constants.h $S/get_perm_cuthill_mckee.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_perm_cuthill_mckee.o ${FCFLAGS_f90} $S/get_perm_cuthill_mckee.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
+
+$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/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
+
+$O/add_missing_nodes.o: $(SPECINC)/constants.h $S/add_missing_nodes.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_missing_nodes.o ${FCFLAGS_f90} $S/add_missing_nodes.f90
+
+$O/compute_coordinates_grid.o: $(SPECINC)/constants.h $S/compute_coordinates_grid.f90
+ ${FCCOMPILE_CHECK} -c -o $O/compute_coordinates_grid.o ${FCFLAGS_f90} $S/compute_coordinates_grid.f90
+
+$O/compute_element_properties.o: $(SPECINC)/constants.h $S/compute_element_properties.f90
+ ${FCCOMPILE_CHECK} -c -o $O/compute_element_properties.o ${FCFLAGS_f90} $S/compute_element_properties.f90
+
+$O/define_superbrick.o: $(SPECINC)/constants.h $S/define_superbrick.f90
+ ${FCCOMPILE_CHECK} -c -o $O/define_superbrick.o ${FCFLAGS_f90} $S/define_superbrick.f90
+
+$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/auto_ner.o: $(SPECINC)/constants.h $S/auto_ner.f90
+ ${FCCOMPILE_CHECK} -c -o $O/auto_ner.o ${FCFLAGS_f90} $S/auto_ner.f90
+
+$O/memory_eval.o: $(SPECINC)/constants.h $S/memory_eval.f90
+ ${FCCOMPILE_CHECK} -c -o $O/memory_eval.o ${FCFLAGS_f90} $S/memory_eval.f90
+
+$O/s362ani.o: $(SPECINC)/constants.h $S/s362ani.f90
+ ${FCCOMPILE_CHECK} -c -o $O/s362ani.o ${FCFLAGS_f90} $S/s362ani.f90
+
+###
+### rule for the header file
+###
+
+OUTPUT_FILES/values_from_mesher.h: create_header_file/$(BIN)/xcreate_header_file
+ mkdir -p OUTPUT_FILES
+ create_header_file/$(BIN)/xcreate_header_file
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.rang
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.rang (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.rang 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,483 @@
+#=====================================================================
+#
+# S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+# --------------------------------------------------
+#
+# 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
+# February 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.
+#
+#=====================================================================
+
+# Makefile. Generated from Makefile.in by configure.
+
+FC = mpif90 -Mcray=pointer -Msmartalloc=huge,hugebss -O3 -tp barcelona-64 -fastsse -Munroll -Knoieee #-Mlarge_arrays -Mnobounds
+FCFLAGS = #-g
+MPIFC = mpif90 -Mcray=pointer -Msmartalloc=huge,hugebss -O3 -tp barcelona-64 -fastsse -Munroll #-Mlarge_arrays -Mnobounds
+MPILIBS =
+FLAGS_NO_CHECK =-fast -Mnobounds -Minline -Mneginfo -Mdclchk -Knoieee -Minform=warn -Mstandard -fastsse #-tp amd64e
+FLAGS_CHECK = $(FLAGS_NO_CHECK)
+FLAGS_NO_CHECK2 = $(FLAGS_NO_CHECK)
+FCFLAGS_f90 =
+
+SPECINC = setup/
+BIN = bin
+
+
+CC = mpicc $(SPECINC) -DNOSECOND_UNDERSCORE
+CFLAGS = -g
+CPPFLAGS =
+
+AR = ar
+ARFLAGS = -c -r -u ## -elf64-x86-64
+RANLIB = ranlib
+
+FCCOMPILE_CHECK = ${FC} ${FCFLAGS} $(FLAGS_CHECK) -I$(SPECINC)
+FCCOMPILE_NO_CHECK = ${FC} ${FCFLAGS} $(FLAGS_NO_CHECK) -I$(SPECINC)
+MPIFCCOMPILE_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_CHECK) -I$(SPECINC)
+MPIFCCOMPILE_NO_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK) -I$(SPECINC)
+MPIFCCOMPILE_NO_CHECK2 = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK2) -I$(SPECINC)
+
+
+O = obj
+S = src
+
+libspecfem_a_OBJECTS = \
+ $O/add_missing_nodes.o \
+ $O/add_topography.o \
+ $O/add_topography_410_650.o \
+ $O/add_topography_cmb.o \
+ $O/add_topography_icb.o \
+ $O/anisotropic_inner_core_model.o \
+ $O/anisotropic_mantle_model.o \
+ $O/assemble_MPI_scalar.o \
+ $O/assemble_MPI_vector.o \
+ $O/attenuation_model.o \
+ $O/calc_jacobian.o \
+ $O/comp_source_spectrum.o \
+ $O/comp_source_time_function.o \
+ $O/compute_arrays_source.o \
+ $O/compute_coordinates_grid.o \
+ $O/compute_element_properties.o \
+ $O/count_number_of_sources.o \
+ $O/create_central_cube_buffers.o \
+ $O/create_chunk_buffers.o \
+ $O/create_header_file.o \
+ $O/create_name_database.o \
+ $O/create_regions_mesh.o \
+ $O/crustal_model.o \
+ $O/define_derivation_matrices.o \
+ $O/define_superbrick.o \
+ $O/euler_angles.o \
+ $O/get_MPI_1D_buffers.o \
+ $O/get_MPI_cutplanes_eta.o \
+ $O/get_MPI_cutplanes_xi.o \
+ $O/get_cmt.o \
+ $O/get_ellipticity.o \
+ $O/get_event_info.o \
+ $O/get_global.o \
+ $O/get_jacobian_boundaries.o \
+ $O/get_model.o \
+ $O/get_perm_cuthill_mckee.o \
+ $O/get_shape2D.o \
+ $O/get_shape3D.o \
+ $O/get_value_parameters.o \
+ $O/gll_library.o \
+ $O/hex_nodes.o \
+ $O/intgrl.o \
+ $O/lagrange_poly.o \
+ $O/lgndr.o \
+ $O/locate_receivers.o \
+ $O/locate_sources.o \
+ $O/make_ellipticity.o \
+ $O/make_gravity.o \
+ $O/mantle_model.o \
+ $O/jp3d1994_model.o \
+ $O/sea99_s_model.o \
+ $O/memory_eval.o \
+ $O/model_1066a.o \
+ $O/model_ak135.o \
+ $O/model_iasp91.o \
+ $O/model_prem.o \
+ $O/model_ref.o \
+ $O/model_jp1d.o \
+ $O/model_sea1d.o \
+ $O/moho_stretching.o \
+ $O/spline_routines.o \
+ $O/create_list_files_chunks.o \
+ $O/recompute_missing_arrays.o \
+ $O/netlib_specfun_erf.o \
+ $O/read_compute_parameters.o \
+ $O/read_value_parameters.o \
+ $O/auto_ner.o \
+ $O/recompute_jacobian.o \
+ $O/reduce.o \
+ $O/rthetaphi_xyz.o \
+ $O/s362ani.o \
+ $O/save_header_file.o \
+ $O/sort_array_coordinates.o \
+ $O/stretching_function.o \
+ $O/topo_bathy.o \
+ $O/write_seismograms.o \
+ $(EMPTY_MACRO)
+
+# solver objects with statically allocated arrays; dependent upon
+# values_from_mesher.h
+SOLVER_ARRAY_OBJECTS = \
+ $O/assemble_MPI_central_cube.o \
+ $O/compute_forces_crust_mantle.o \
+ $O/compute_forces_inner_core.o \
+ $O/compute_forces_outer_core.o \
+ $O/specfem3D.o \
+ $(EMPTY_MACRO)
+
+LIBSPECFEM = $O/libspecfem.a
+
+
+####
+#### targets
+####
+
+# default targets
+DEFAULT = \
+ xcreate_header_file \
+ OUTPUT_FILES/values_from_mesher.h \
+ xmeshfem3D \
+ $(EMPTY_MACRO)
+
+default: $(DEFAULT)
+
+all: clean default
+
+backup:
+ cp *f90 *h README_SPECFEM3D_GLOBE DATA/Par_file* Makefile go_mesher go_solver mymachines bak
+
+bak: backup
+
+
+####
+#### rules for executables
+####
+
+# rules for the main programs
+XMESHFEM_OBJECTS = $O/meshfem3D.o $O/exit_mpi.o $(SOLVER_ARRAY_OBJECTS) $(LIBSPECFEM)
+xmeshfem3D: $(XMESHFEM_OBJECTS)
+## use MPI here
+ ${MPIFCCOMPILE_CHECK} -o $(BIN)/xmeshfem3D $(XMESHFEM_OBJECTS) $(MPILIBS)
+
+# solver also depends on values from mesher
+XSPECFEM_OBJECTS = $(SOLVER_ARRAY_OBJECTS) $O/exit_mpi.o $(LIBSPECFEM)
+
+xconvolve_source_timefunction: $O/convolve_source_timefunction.o
+ ${FCCOMPILE_CHECK} -o xconvolve_source_timefunction $O/convolve_source_timefunction.o
+
+xcreate_header_file: $O/create_header_file.o $O/exit_mpi.o $O/get_value_parameters.o $O/read_compute_parameters.o $O/memory_eval.o $O/save_header_file.o $O/count_number_of_sources.o $O/read_value_parameters.o $O/euler_angles.o $O/reduce.o $O/rthetaphi_xyz.o $O/auto_ner.o
+ ${MPIFCCOMPILE_CHECK} -o $(BIN)/xcreate_header_file $O/create_header_file.o $O/exit_mpi.o $O/get_value_parameters.o $O/read_compute_parameters.o $O/memory_eval.o $O/save_header_file.o $O/count_number_of_sources.o $O/read_value_parameters.o $O/euler_angles.o $O/reduce.o $O/rthetaphi_xyz.o $O/auto_ner.o
+
+clean:
+ rm -f $O/* *.o work.pc* *.mod $(BIN)/xmeshfem3D $(BIN)/xconvolve_source_timefunction $(BIN)/xcreate_header_file PI*
+
+
+###
+### rule for the archive library
+###
+
+$O/libspecfem.a: $(libspecfem_a_OBJECTS)
+ -rm -f $O/libspecfem.a
+ $(AR) $(ARFLAGS) $O/libspecfem.a $(libspecfem_a_OBJECTS)
+ $(RANLIB) $O/libspecfem.a
+
+####
+#### rule for each .o file below
+####
+
+###
+### optimized flags and dependence on values from mesher here
+###
+
+$O/specfem3D.o: $(SPECINC)/constants.h OUTPUT_FILES/values_from_mesher.h $S/specfem3D.f90
+ ${MPIFCCOMPILE_NO_CHECK2} -c -o $O/specfem3D.o ${FCFLAGS_f90} $S/specfem3D.f90
+
+$O/compute_forces_crust_mantle.o: $(SPECINC)/constants.h OUTPUT_FILES/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
+
+$O/compute_forces_outer_core.o: $(SPECINC)/constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_outer_core.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_outer_core.o ${FCFLAGS_f90} $S/compute_forces_outer_core.f90
+
+$O/compute_forces_inner_core.o: $(SPECINC)/constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_inner_core.f90
+ ${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
+
+### 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_central_cube.o: $(SPECINC)/constants.h OUTPUT_FILES/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
+###
+
+$O/convolve_source_timefunction.o: $S/convolve_source_timefunction.f90
+ ${FCCOMPILE_CHECK} -c -o $O/convolve_source_timefunction.o ${FCFLAGS_f90} $S/convolve_source_timefunction.f90
+
+$O/create_header_file.o: $S/create_header_file.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_header_file.o ${FCFLAGS_f90} $S/create_header_file.f90
+
+$O/comp_source_time_function.o: $S/comp_source_time_function.f90
+ ${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/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
+
+### 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
+
+## 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/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
+
+$O/read_value_parameters.o: $(SPECINC)/constants.h $S/read_value_parameters.f90
+ ${FCCOMPILE_CHECK} -c -o $O/read_value_parameters.o ${FCFLAGS_f90} $S/read_value_parameters.f90
+
+$O/get_value_parameters.o: $(SPECINC)/constants.h $S/get_value_parameters.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_value_parameters.o ${FCFLAGS_f90} $S/get_value_parameters.f90
+
+$O/topo_bathy.o: $(SPECINC)/constants.h $S/topo_bathy.f90
+ ${FCCOMPILE_CHECK} -c -o $O/topo_bathy.o ${FCFLAGS_f90} $S/topo_bathy.f90
+
+$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/crustal_model.o: $(SPECINC)/constants.h $S/crustal_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/crustal_model.o ${FCFLAGS_f90} $S/crustal_model.f90
+
+$O/make_ellipticity.o: $(SPECINC)/constants.h $S/make_ellipticity.f90
+ ${FCCOMPILE_CHECK} -c -o $O/make_ellipticity.o ${FCFLAGS_f90} $S/make_ellipticity.f90
+
+$O/get_jacobian_boundaries.o: $(SPECINC)/constants.h $S/get_jacobian_boundaries.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_jacobian_boundaries.o ${FCFLAGS_f90} $S/get_jacobian_boundaries.f90
+
+$O/get_MPI_cutplanes_xi.o: $(SPECINC)/constants.h $S/get_MPI_cutplanes_xi.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_MPI_cutplanes_xi.o ${FCFLAGS_f90} $S/get_MPI_cutplanes_xi.f90
+
+$O/get_MPI_cutplanes_eta.o: $(SPECINC)/constants.h $S/get_MPI_cutplanes_eta.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_MPI_cutplanes_eta.o ${FCFLAGS_f90} $S/get_MPI_cutplanes_eta.f90
+
+$O/get_MPI_1D_buffers.o: $(SPECINC)/constants.h $S/get_MPI_1D_buffers.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_MPI_1D_buffers.o ${FCFLAGS_f90} $S/get_MPI_1D_buffers.f90
+
+$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_ellipticity.o: $(SPECINC)/constants.h $S/get_ellipticity.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_ellipticity.o ${FCFLAGS_f90} $S/get_ellipticity.f90
+
+$O/get_global.o: $(SPECINC)/constants.h $S/get_global.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_global.o ${FCFLAGS_f90} $S/get_global.f90
+
+$O/make_gravity.o: $(SPECINC)/constants.h $S/make_gravity.f90
+ ${FCCOMPILE_CHECK} -c -o $O/make_gravity.o ${FCFLAGS_f90} $S/make_gravity.f90
+
+$O/rthetaphi_xyz.o: $(SPECINC)/constants.h $S/rthetaphi_xyz.f90
+ ${FCCOMPILE_CHECK} -c -o $O/rthetaphi_xyz.o ${FCFLAGS_f90} $S/rthetaphi_xyz.f90
+
+$O/get_model.o: $(SPECINC)/constants.h $S/get_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_model.o ${FCFLAGS_f90} $S/get_model.f90
+
+$O/get_shape3D.o: $(SPECINC)/constants.h $S/get_shape3D.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_shape3D.o ${FCFLAGS_f90} $S/get_shape3D.f90
+
+$O/get_shape2D.o: $(SPECINC)/constants.h $S/get_shape2D.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_shape2D.o ${FCFLAGS_f90} $S/get_shape2D.f90
+
+$O/hex_nodes.o: $(SPECINC)/constants.h $S/hex_nodes.f90
+ ${FCCOMPILE_CHECK} -c -o $O/hex_nodes.o ${FCFLAGS_f90} $S/hex_nodes.f90
+
+$O/intgrl.o: $(SPECINC)/constants.h $S/intgrl.f90
+ ${FCCOMPILE_CHECK} -c -o $O/intgrl.o ${FCFLAGS_f90} $S/intgrl.f90
+
+$O/mantle_model.o: $(SPECINC)/constants.h $S/mantle_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/mantle_model.o ${FCFLAGS_f90} $S/mantle_model.f90
+
+$O/jp3d1994_model.o: $(SPECINC)/constants.h $S/jp3d1994_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/jp3d1994_model.o ${FCFLAGS_f90} $S/jp3d1994_model.f90
+
+$O/sea99_s_model.o: $(SPECINC)/constants.h $S/sea99_s_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/sea99_s_model.o ${FCFLAGS_f90} $S/sea99_s_model.f90
+
+$O/euler_angles.o: $(SPECINC)/constants.h $S/euler_angles.f90
+ ${FCCOMPILE_CHECK} -c -o $O/euler_angles.o ${FCFLAGS_f90} $S/euler_angles.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/spline_routines.o: $(SPECINC)/constants.h $S/spline_routines.f90
+ ${FCCOMPILE_CHECK} -c -o $O/spline_routines.o ${FCFLAGS_f90} $S/spline_routines.f90
+
+$O/create_list_files_chunks.o: $(SPECINC)/constants.h $S/create_list_files_chunks.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_list_files_chunks.o ${FCFLAGS_f90} $S/create_list_files_chunks.f90
+
+$O/recompute_missing_arrays.o: $(SPECINC)/constants.h $S/recompute_missing_arrays.f90
+ ${FCCOMPILE_CHECK} -c -o $O/recompute_missing_arrays.o ${FCFLAGS_f90} $S/recompute_missing_arrays.f90
+
+$O/netlib_specfun_erf.o: $S/netlib_specfun_erf.f90
+ ${FCCOMPILE_CHECK} -c -o $O/netlib_specfun_erf.o ${FCFLAGS_f90} $S/netlib_specfun_erf.f90
+
+$O/lgndr.o: $(SPECINC)/constants.h $S/lgndr.f90
+ ${FCCOMPILE_CHECK} -c -o $O/lgndr.o ${FCFLAGS_f90} $S/lgndr.f90
+
+$O/model_prem.o: $(SPECINC)/constants.h $S/model_prem.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_prem.o ${FCFLAGS_f90} $S/model_prem.f90
+
+$O/model_iasp91.o: $(SPECINC)/constants.h $S/model_iasp91.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_iasp91.o ${FCFLAGS_f90} $S/model_iasp91.f90
+
+$O/model_1066a.o: $(SPECINC)/constants.h $S/model_1066a.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_1066a.o ${FCFLAGS_f90} $S/model_1066a.f90
+
+$O/model_ak135.o: $(SPECINC)/constants.h $S/model_ak135.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_ak135.o ${FCFLAGS_f90} $S/model_ak135.f90
+
+$O/model_ref.o: $(SPECINC)/constants.h $S/model_ref.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_ref.o ${FCFLAGS_f90} $S/model_ref.f90
+
+$O/model_jp1d.o: $(SPECINC)/constants.h $S/model_jp1d.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_jp1d.o ${FCFLAGS_f90} $S/model_jp1d.f90
+
+$O/model_sea1d.o: $(SPECINC)/constants.h $S/model_sea1d.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_sea1d.o ${FCFLAGS_f90} $S/model_sea1d.f90
+
+$O/anisotropic_mantle_model.o: $(SPECINC)/constants.h $S/anisotropic_mantle_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/anisotropic_mantle_model.o ${FCFLAGS_f90} $S/anisotropic_mantle_model.f90
+
+$O/anisotropic_inner_core_model.o: $(SPECINC)/constants.h $S/anisotropic_inner_core_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/anisotropic_inner_core_model.o ${FCFLAGS_f90} $S/anisotropic_inner_core_model.f90
+
+$O/reduce.o: $(SPECINC)/constants.h $S/reduce.f90
+ ${FCCOMPILE_CHECK} -c -o $O/reduce.o ${FCFLAGS_f90} $S/reduce.f90
+
+$O/save_header_file.o: $(SPECINC)/constants.h $S/save_header_file.f90
+ ${FCCOMPILE_CHECK} -c -o $O/save_header_file.o ${FCFLAGS_f90} $S/save_header_file.f90
+
+$O/comp_source_spectrum.o: $(SPECINC)/constants.h $S/comp_source_spectrum.f90
+ ${FCCOMPILE_CHECK} -c -o $O/comp_source_spectrum.o ${FCFLAGS_f90} $S/comp_source_spectrum.f90
+
+$O/add_topography.o: $(SPECINC)/constants.h $S/add_topography.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_topography.o ${FCFLAGS_f90} $S/add_topography.f90
+
+$O/moho_stretching.o: $(SPECINC)/constants.h $S/moho_stretching.f90
+ ${FCCOMPILE_CHECK} -c -o $O/moho_stretching.o ${FCFLAGS_f90} $S/moho_stretching.f90
+
+$O/add_topography_410_650.o: $(SPECINC)/constants.h $S/add_topography_410_650.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_topography_410_650.o ${FCFLAGS_f90} $S/add_topography_410_650.f90
+
+$O/add_topography_cmb.o: $(SPECINC)/constants.h $S/add_topography_cmb.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_topography_cmb.o ${FCFLAGS_f90} $S/add_topography_cmb.f90
+
+$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/lagrange_poly.o: $(SPECINC)/constants.h $S/lagrange_poly.f90
+ ${FCCOMPILE_CHECK} -c -o $O/lagrange_poly.o ${FCFLAGS_f90} $S/lagrange_poly.f90
+
+$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
+ ${FCCOMPILE_CHECK} -c -o $O/create_regions_mesh.o ${FCFLAGS_f90} $S/create_regions_mesh.f90
+
+$O/create_name_database.o: $(SPECINC)/constants.h $S/create_name_database.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_name_database.o ${FCFLAGS_f90} $S/create_name_database.f90
+
+$O/get_perm_cuthill_mckee.o: $(SPECINC)/constants.h $S/get_perm_cuthill_mckee.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_perm_cuthill_mckee.o ${FCFLAGS_f90} $S/get_perm_cuthill_mckee.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
+
+$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/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
+
+$O/add_missing_nodes.o: $(SPECINC)/constants.h $S/add_missing_nodes.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_missing_nodes.o ${FCFLAGS_f90} $S/add_missing_nodes.f90
+
+$O/compute_coordinates_grid.o: $(SPECINC)/constants.h $S/compute_coordinates_grid.f90
+ ${FCCOMPILE_CHECK} -c -o $O/compute_coordinates_grid.o ${FCFLAGS_f90} $S/compute_coordinates_grid.f90
+
+$O/compute_element_properties.o: $(SPECINC)/constants.h $S/compute_element_properties.f90
+ ${FCCOMPILE_CHECK} -c -o $O/compute_element_properties.o ${FCFLAGS_f90} $S/compute_element_properties.f90
+
+$O/define_superbrick.o: $(SPECINC)/constants.h $S/define_superbrick.f90
+ ${FCCOMPILE_CHECK} -c -o $O/define_superbrick.o ${FCFLAGS_f90} $S/define_superbrick.f90
+
+$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/auto_ner.o: $(SPECINC)/constants.h $S/auto_ner.f90
+ ${FCCOMPILE_CHECK} -c -o $O/auto_ner.o ${FCFLAGS_f90} $S/auto_ner.f90
+
+$O/memory_eval.o: $(SPECINC)/constants.h $S/memory_eval.f90
+ ${FCCOMPILE_CHECK} -c -o $O/memory_eval.o ${FCFLAGS_f90} $S/memory_eval.f90
+
+$O/s362ani.o: $(SPECINC)/constants.h $S/s362ani.f90
+ ${FCCOMPILE_CHECK} -c -o $O/s362ani.o ${FCFLAGS_f90} $S/s362ani.f90
+
+###
+### rule for the header file
+###
+
+OUTPUT_FILES/values_from_mesher.h: $(BIN)/xcreate_header_file
+ mkdir -p OUTPUT_FILES
+ $(BIN)/xcreate_header_file
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_missing_nodes.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_missing_nodes.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_missing_nodes.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,165 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! compute the missing nodes of a 27-node element when only the 8 corners have been given
-
-! the topology of the nodes is described in file hex_nodes.f90 as well as in
-! UTILS/chunk_notes_scanned/numbering_convention_27_nodes.*
-
- subroutine add_missing_nodes(offset_x,offset_y,offset_z)
-
- implicit none
-
- include "constants.h"
-
- double precision, dimension(NGNOD) :: offset_x,offset_y,offset_z
-
-! list of corners defining the edges and the faces
- integer, parameter :: NEDGES = 12, NFACES = 6
- integer, dimension(NEDGES,2) :: list_corners_edge
- integer, dimension(NFACES,4) :: list_corners_face
-
- integer :: iedge,iface,ignod
-
-! list of corners defining the edges
-! the edge number is sorted according to the numbering convention defined in file hex_nodes.f90
-! as well as in DATA/util/YYYYYYYYYYYYYYYYYYYYYYYYYYY DK DK UGLY YYYYYYYYYYYYYYYYYYY
-
- list_corners_edge( 1,1) = 1
- list_corners_edge( 1,2) = 2
-
- list_corners_edge( 2,1) = 2
- list_corners_edge( 2,2) = 3
-
- list_corners_edge( 3,1) = 3
- list_corners_edge( 3,2) = 4
-
- list_corners_edge( 4,1) = 4
- list_corners_edge( 4,2) = 1
-
- list_corners_edge( 5,1) = 1
- list_corners_edge( 5,2) = 5
-
- list_corners_edge( 6,1) = 2
- list_corners_edge( 6,2) = 6
-
- list_corners_edge( 7,1) = 3
- list_corners_edge( 7,2) = 7
-
- list_corners_edge( 8,1) = 4
- list_corners_edge( 8,2) = 8
-
- list_corners_edge( 9,1) = 5
- list_corners_edge( 9,2) = 6
-
- list_corners_edge(10,1) = 6
- list_corners_edge(10,2) = 7
-
- list_corners_edge(11,1) = 7
- list_corners_edge(11,2) = 8
-
- list_corners_edge(12,1) = 8
- list_corners_edge(12,2) = 5
-
-! list of corners defining the faces
-! the face number is sorted according to the numbering convention defined in file hex_nodes.f90
-! as well as in DATA/util/YYYYYYYYYYYYYYYYYYYYYYYYYYY DK DK UGLY YYYYYYYYYYYYYYYYYYY
-
- list_corners_face(1,1) = 1
- list_corners_face(1,2) = 2
- list_corners_face(1,3) = 3
- list_corners_face(1,4) = 4
-
- list_corners_face(2,1) = 1
- list_corners_face(2,2) = 2
- list_corners_face(2,3) = 6
- list_corners_face(2,4) = 5
-
- list_corners_face(3,1) = 2
- list_corners_face(3,2) = 3
- list_corners_face(3,3) = 7
- list_corners_face(3,4) = 6
-
- list_corners_face(4,1) = 4
- list_corners_face(4,2) = 3
- list_corners_face(4,3) = 7
- list_corners_face(4,4) = 8
-
- list_corners_face(5,1) = 1
- list_corners_face(5,2) = 4
- list_corners_face(5,3) = 8
- list_corners_face(5,4) = 5
-
- list_corners_face(6,1) = 5
- list_corners_face(6,2) = 6
- list_corners_face(6,3) = 7
- list_corners_face(6,4) = 8
-
-! midside nodes (nodes located in the middle of an edge)
- do iedge = 1,NEDGES
-
-! node numbers for edge centers start at 9
- ignod = (iedge - 1) + 9
-
- offset_x(ignod) = (offset_x(list_corners_edge(iedge,1)) + offset_x(list_corners_edge(iedge,2))) / 2.d0
-
- offset_y(ignod) = (offset_y(list_corners_edge(iedge,1)) + offset_y(list_corners_edge(iedge,2))) / 2.d0
-
- offset_z(ignod) = (offset_z(list_corners_edge(iedge,1)) + offset_z(list_corners_edge(iedge,2))) / 2.d0
-
- enddo
-
-! side center nodes (nodes located in the middle of a face)
- do iface = 1,NFACES
-
-! node numbers for face centers start at 21
- ignod = (iface - 1) + 21
-
- offset_x(ignod) = (offset_x(list_corners_face(iface,1)) + &
- offset_x(list_corners_face(iface,2)) + &
- offset_x(list_corners_face(iface,3)) + &
- offset_x(list_corners_face(iface,4))) / 4.d0
-
- offset_y(ignod) = (offset_y(list_corners_face(iface,1)) + &
- offset_y(list_corners_face(iface,2)) + &
- offset_y(list_corners_face(iface,3)) + &
- offset_y(list_corners_face(iface,4))) / 4.d0
-
- offset_z(ignod) = (offset_z(list_corners_face(iface,1)) + &
- offset_z(list_corners_face(iface,2)) + &
- offset_z(list_corners_face(iface,3)) + &
- offset_z(list_corners_face(iface,4))) / 4.d0
-
- enddo
-
-! center node (barycenter of the eight corners)
- offset_x(27) = sum(offset_x(1:NGNOD_EIGHT_CORNERS)) / dble(NGNOD_EIGHT_CORNERS)
- offset_y(27) = sum(offset_y(1:NGNOD_EIGHT_CORNERS)) / dble(NGNOD_EIGHT_CORNERS)
- offset_z(27) = sum(offset_z(1:NGNOD_EIGHT_CORNERS)) / dble(NGNOD_EIGHT_CORNERS)
-
- end subroutine add_missing_nodes
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,87 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
-
- implicit none
-
- include "constants.h"
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
- integer myrank
-
-! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
- integer ia
-
- double precision lat,lon,elevation,R220
- double precision r,theta,phi,colat
- double precision gamma
-
-! we loop on all the points of the element
- do ia = 1,NGNOD
-
-! convert to r theta phi
-! slightly move points to avoid roundoff problem when exactly on the polar axis
- call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
- theta = theta + 0.0000001d0
- phi = phi + 0.0000001d0
- call reduce(theta,phi)
-
-! convert the geocentric colatitude to a geographic colatitude
- colat = PI/2.0d0 - datan(1.006760466d0*dcos(theta)/dmax1(TINYVAL,dsin(theta)))
-
-! get geographic latitude and longitude in degrees
- lat = 90.0d0 - colat*180.0d0/PI
- lon = phi*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
- elevation = elevation / R_EARTH
-
-! stretching topography between d220 and the surface
- gamma = (r - R220/R_EARTH) / (R_UNIT_SPHERE - R220/R_EARTH)
-
-! add elevation to all the points of that element
-! also make sure gamma makes sense
- if(gamma < -0.02 .or. gamma > 1.02) call exit_MPI(myrank,'incorrect value of gamma for topography')
-
- xelm(ia) = xelm(ia)*(ONE + gamma * elevation / r)
- yelm(ia) = yelm(ia)*(ONE + gamma * elevation / r)
- zelm(ia) = zelm(ia)*(ONE + gamma * elevation / r)
-
- enddo
-
- end subroutine add_topography
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_410_650.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_410_650.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_410_650.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,134 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 add_topography_410_650(myrank,xelm,yelm,zelm,R220,R400,R670,R771, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,ylmcof,wk1,wk2,wk3,varstr)
-
- implicit none
-
- include "constants.h"
-
- integer myrank
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
- double precision R220,R400,R670,R771
-
- integer ia
-
- real(kind=4) xcolat,xlon
- real(kind=4) topo410out,topo650out
- double precision topo410,topo650
-
- double precision r,theta,phi
- double precision gamma
-
- 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) 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=40) varstr(maxker)
-
-! we loop on all the points of the element
- do ia = 1,NGNOD
-
-! convert to r theta phi
- call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
- call reduce(theta,phi)
-
-! get colatitude and longitude in degrees
- xcolat = sngl(theta*180.0d0/PI)
- xlon = sngl(phi*180.0d0/PI)
-
-! compute topography on 410 and 650 at current point
- call subtopo(xcolat,xlon,topo410out,topo650out, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,ylmcof,wk1,wk2,wk3,varstr)
-
-! non-dimensionalize the topography, which is in km
-! positive for a depression, so change the sign for a perturbation in radius
- topo410 = -dble(topo410out) / R_EARTH_KM
- topo650 = -dble(topo650out) / R_EARTH_KM
-
- gamma = 0.d0
- if(r >= R400/R_EARTH .and. r <= R220/R_EARTH) then
-! stretching between R220 and R400
- gamma = (R220/R_EARTH - r) / (R220/R_EARTH - R400/R_EARTH)
- xelm(ia) = xelm(ia)*(ONE + gamma * topo410 / r)
- yelm(ia) = yelm(ia)*(ONE + gamma * topo410 / r)
- zelm(ia) = zelm(ia)*(ONE + gamma * topo410 / r)
- elseif(r>= R771/R_EARTH .and. r <= R670/R_EARTH) then
-! stretching between R771 and R670
- gamma = (r - R771/R_EARTH) / (R670/R_EARTH - R771/R_EARTH)
- xelm(ia) = xelm(ia)*(ONE + gamma * topo650 / r)
- yelm(ia) = yelm(ia)*(ONE + gamma * topo650 / r)
- zelm(ia) = zelm(ia)*(ONE + gamma * topo650 / r)
- elseif(r > R670/R_EARTH .and. r < R400/R_EARTH) then
-! stretching between R670 and R400
- gamma = (R400/R_EARTH - r) / (R400/R_EARTH - R670/R_EARTH)
- xelm(ia) = xelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
- yelm(ia) = yelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
- zelm(ia) = zelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
- endif
- if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for 410-650 topography')
-
- enddo
-
- end subroutine add_topography_410_650
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_cmb.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_cmb.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_cmb.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,84 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 add_topography_cmb(myrank,xelm,yelm,zelm,RTOPDDOUBLEPRIME,RCMB)
-
- implicit none
-
- include "constants.h"
-
- integer myrank
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
- double precision RTOPDDOUBLEPRIME,RCMB
-
- integer ia
-
- double precision r_start,topocmb
-
- double precision r,theta,phi
- double precision gamma
-
-! we loop on all the points of the element
- do ia = 1,NGNOD
-
-! convert to r theta phi
- call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
- call reduce(theta,phi)
-
-! compute topography on CMB; routine subtopo_cmb needs to be supplied by the user
-! call subtopo_cmb(theta,phi,topocmb)
- topocmb = 0.0d0
-
-! non-dimensionalize the topography, which is in km
-! positive for a depression, so change the sign for a perturbation in radius
- topocmb = -topocmb / R_EARTH_KM
-
-! start stretching a distance RTOPDDOUBLEPRIME - RCMB below the CMB
-! and finish at RTOPDDOUBLEPRIME (D'')
- r_start = (RCMB - (RTOPDDOUBLEPRIME - RCMB))/R_EARTH
- gamma = 0.0d0
- if(r >= RCMB/R_EARTH .and. r <= RTOPDDOUBLEPRIME/R_EARTH) then
-! stretching between RCMB and RTOPDDOUBLEPRIME
- gamma = (RTOPDDOUBLEPRIME/R_EARTH - r) / (RTOPDDOUBLEPRIME/R_EARTH - RCMB/R_EARTH)
- elseif(r>= r_start .and. r <= RCMB/R_EARTH) then
-! stretching between r_start and RCMB
- gamma = (r - r_start) / (RCMB/R_EARTH - r_start)
- endif
- if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for CMB topography')
-
- xelm(ia) = xelm(ia)*(ONE + gamma * topocmb / r)
- yelm(ia) = yelm(ia)*(ONE + gamma * topocmb / r)
- zelm(ia) = zelm(ia)*(ONE + gamma * topocmb / r)
-
- enddo
-
- end subroutine add_topography_cmb
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_icb.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_icb.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_icb.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,81 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 add_topography_icb(myrank,xelm,yelm,zelm,RICB,RCMB)
-
- implicit none
-
- include "constants.h"
-
- integer myrank
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
- double precision RICB,RCMB
-
- integer ia
-
- double precision topoicb
-
- double precision r,theta,phi
- double precision gamma
-
-! we loop on all the points of the element
- do ia = 1,NGNOD
-
-! convert to r theta phi
- call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
- call reduce(theta,phi)
-
-! compute topography on ICB; the routine subtopo_icb needs to be supplied by the user
-! call subtopo_icb(theta,phi,topoicb)
- topoicb = 0.0d0
-
-! non-dimensionalize the topography, which is in km
-! positive for a depression, so change the sign for a perturbation in radius
- topoicb = -topoicb / R_EARTH_KM
-
- gamma = 0.0d0
- if(r > 0.0d0 .and. r <= RICB/R_EARTH) then
-! stretching between center and RICB
- gamma = r/(RICB/R_EARTH)
- elseif(r>= RICB/R_EARTH .and. r <= RCMB/R_EARTH) then
-! stretching between RICB and RCMB
- gamma = (r - RCMB/R_EARTH) / (RICB/R_EARTH - RCMB/R_EARTH)
- endif
- if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for CMB topography')
-
- xelm(ia) = xelm(ia)*(ONE + gamma * topoicb / r)
- yelm(ia) = yelm(ia)*(ONE + gamma * topoicb / r)
- zelm(ia) = zelm(ia)*(ONE + gamma * topoicb / r)
-
- enddo
-
- end subroutine add_topography_icb
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_1.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_1.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_1.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,228 +0,0 @@
-
- allocate(xstore_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(ystore_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(zstore_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
- allocate(xstore_outer_core(NGLOB_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
-
-
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(ystore_outer_core(NGLOB_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
-
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(zstore_outer_core(NGLOB_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
- allocate(xstore_inner_core(NGLOB_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(ystore_inner_core(NGLOB_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(zstore_inner_core(NGLOB_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
-!---
-
- allocate(xix_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(xiy_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(xiz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(etax_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(etay_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(etaz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(gammax_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(gammay_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(gammaz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
- allocate(xix_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(xiy_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(xiz_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(etax_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(etay_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(etaz_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(gammax_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(gammay_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(gammaz_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
- allocate(xix_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(xiy_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(xiz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(etax_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(etay_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(etaz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(gammax_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(gammay_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(gammaz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_2.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_2.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_2.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,98 +0,0 @@
-
- allocate(rmass_ocean_load(NGLOB_CRUST_MANTLE_OCEANS),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-!---
-
- allocate(displ_crust_mantle(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(veloc_crust_mantle(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(accel_crust_mantle(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
- allocate(displ_outer_core(NGLOB_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(veloc_outer_core(NGLOB_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(accel_outer_core(NGLOB_OUTER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
- allocate(displ_inner_core(NDIM,NGLOB_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(veloc_inner_core(NDIM,NGLOB_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(accel_inner_core(NDIM,NGLOB_INNER_CORE),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
-!---
-
- allocate(R_memory_crust_mantle(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
- allocate(R_memory_inner_core(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
-!---
-
- allocate(epsilondev_crust_mantle(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
- allocate(epsilondev_inner_core(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT),stat=ier)
- if(ier /= 0) then
- print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_before.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_before.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_before.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -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'
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_inner_core_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_inner_core_model.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_inner_core_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,146 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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_aniso_inner_core_model
-
- implicit none
-
-! one should add an MPI_BCAST in meshfem3D.f90 if one adds a read_aniso_inner_core_model subroutine
-
- end subroutine read_aniso_inner_core_model
-
-!-----------------------------------
-
- subroutine aniso_inner_core_model(x,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL)
-
- implicit none
-
- include "constants.h"
-
-! given a normalized radius x, gives non-dimensionalized c11,c33,c12,c13,c44
-
- integer REFERENCE_1D_MODEL
-
- double precision x,c11,c33,c12,c13,c44
-
- double precision vp,vs,rho
- double precision vp0,vs0,rho0,A0
- double precision c66
- double precision scale_fac
-
- if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
- vp=11.24094d0-4.09689d0*x*x
- vs=3.56454d0-3.45241d0*x*x
- rho=13.0885d0-8.8381d0*x*x
-
-! values at center
- vp0=11.24094d0
- vs0=3.56454d0
- rho0=13.0885d0
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
- vp=11.2622d0-6.3640d0*x*x
- vs=3.6678d0-4.4475d0*x*x
- rho=13.0885d0-8.8381d0*x*x
-
-! values at center
- vp0=11.2622d0
- vs0=3.6678d0
- rho0=13.0885d0
-
- else
- stop 'unknown 1D reference Earth model in anisotropic inner core'
- endif
-
-! elastic tensor for hexagonal symmetry in reduced notation:
-!
-! c11 c12 c13 0 0 0
-! c12 c11 c13 0 0 0
-! c13 c13 c33 0 0 0
-! 0 0 0 c44 0 0
-! 0 0 0 0 c44 0
-! 0 0 0 0 0 c66=(c11-c12)/2
-!
-! in terms of the A, C, L, N and F of Love (1927):
-!
-! c11 = A
-! c33 = C
-! c12 = A-2N
-! c13 = F
-! c44 = L
-! c66 = N
-!
-! isotropic equivalent:
-!
-! c11 = lambda+2mu
-! c33 = lambda+2mu
-! c12 = lambda
-! c13 = lambda
-! c44 = mu
-! c66 = mu
-
-! non-dimensionalization of elastic parameters
- scale_fac=RHOAV*R_EARTH*R_EARTH*PI*GRAV*RHOAV
-
-! Ishii et al. (2002):
-!
-! alpha = 3.490 % = (C-A)/A0 = (c33-c11)/A0
-! beta = 0.988 % = (L-N)/A0 = (c44-c66)/A0
-! gamma = 0.881 % = (A-2N-F)/A0 = (c12-c13)/A0
-! where A0 is A at the Earth's center
-!
-! assume c11 = lamda+2mu
-! c66 = (c11-c12)/2 = mu
-!
-! then c33 = c11 + alpha*A0
-! c44 = c66 + beta*A0
-! c13 = c12 - gamma*A0
-!
-! Steinle-Neumann (2002):
-!
-! r T rho c11 c12 c13 c33 c44 KS mu
-! (km) (K) (Mg/m3) (GPa)
-! 0 5735 13.09 1693 1253 1364 1813 154 1457 184
-! 200 5729 13.08 1689 1251 1362 1809 154 1455 184
-! 400 5711 13.05 1676 1243 1353 1795 151 1444 181
-! 600 5682 13.01 1661 1232 1341 1779 150 1432 180
-! 800 5642 12.95 1638 1214 1321 1755 148 1411 178
-! 1000 5590 12.87 1606 1190 1295 1720 146 1383 175
-! 1200 5527 12.77 1559 1155 1257 1670 141 1343 169
-!
-
- c11=rho*vp*vp*1.d9/scale_fac
- c66=rho*vs*vs*1.d9/scale_fac
-
- A0=rho0*vp0*vp0*1.d9/scale_fac
- c33=c11+0.0349d0*A0
- c44=c66+0.00988d0*A0
- c12=c11-2.0d0*c66
- c13=c12-0.00881d0*A0
-
- end subroutine aniso_inner_core_model
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_mantle_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_mantle_model.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_mantle_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,864 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-!=====================================================================
-!
-! Jean-Paul Montagner, January 2002
-! modified by Min Chen, Caltech, February 2002
-!
-! input is (r, theta, phi), output is the matrix cij(6x6)
-! 0 <= r <= 1, 0 <= theta <= pi, 0 <= phi <= 2 pi
-!
-! returns non-dimensionalized cij
-!
-! creates parameters p(i=1,14,r,theta,phi)
-! from model glob-prem3sm01 globpreman3sm01 (Montagner, 2002)
-!
-!======================================================================
-
-
- subroutine aniso_mantle_model(r,theta,phi,rho, &
- c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,&
- AMM_V)
-
- implicit none
-
- include "constants.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
-
- double precision r,theta,phi
- double precision rho
- double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26, &
- c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
-
- double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
- d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
-
- double precision colat,lon
-
- lon = phi / DEGREES_TO_RADIANS
- 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')
-
-! assign the local (d_ij) or global (c_ij) anisotropic parameters.
-! The c_ij are the coefficients in the global
-! reference frame used in SPECFEM3D.
- call build_cij(AMM_V%pro,AMM_V%npar1,rho,AMM_V%beta,r,colat,lon,&
- d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,d33,d34,d35,d36,&
- d44,d45,d46,d55,d56,d66)
-
- call rotate_aniso_tensor(theta,phi,d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,&
- d33,d34,d35,d36,d44,d45,d46,d55,d56,d66,&
- c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
- c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
-
- end subroutine aniso_mantle_model
-
-!--------------------------------------------------------------------
-
- subroutine build_cij(pro,npar1,rho,beta,r,theta,phi,&
- d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,d33,d34,d35,d36,&
- d44,d45,d46,d55,d56,d66)
-
- implicit none
-
- include "constants.h"
-
- integer npar1,ndepth,idep,ipar,itheta,ilon,icz0,nx0,ny0,nz0,&
- ict0,ict1,icp0,icp1,icz1
-
- double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
- d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
- double precision r,theta,phi,rho,depth,tei,tet,ph,fi,x0,y0,pxy0
- double precision d1,d2,d3,d4,sd,thickness,dprof1,dprof2,eps,pc1,pc2,pc3,pc4,&
- dpr1,dpr2,param,scale_GPa,scaleval
- double precision A,C,F,AL,AN,BC,BS,GC,GS,HC,HS,EC,ES,C1p,C1sv,C1sh,C3,S1p,S1sv,S1sh,S3
- double precision beta(14,34,37,73),pro(47)
- double precision anispara(14,2,4),elpar(14)
-
- ndepth = npar1
- pxy0 = 5.
- x0 = 0.
- y0 = 0.
- nx0 = 37
- ny0 = 73
- nz0 = 34
-
-! avoid edge effects
- if(theta==0.0d0) theta=0.000001d0
- if(theta==180.d0) theta=0.999999d0*theta
- if(phi==0.0d0) phi=0.000001d0
- if(phi==360.d0) phi=0.999999d0*phi
-
-! 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')
- itheta = int(theta + pxy0)/pxy0
- ilon = int(phi + pxy0)/pxy0
- tet = theta
- ph = phi
-
- icz0 = 0
- do idep = 1,ndepth
- if(pro(idep) > depth) icz0 = icz0 + 1
- enddo
-
-!
-! Interpolation for depth between dep1(iz0) and dep2(iz1)
-!
-! 1 (ict0,icp0) 2 (ict0,icp1)
-! 3 (ict1,icp0) 4 (ict1,icp1)
-!
-
- ict0 = itheta
- ict1 = ict0 + 1
- icp0 = ilon
- icp1 = icp0 + 1
- 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')
-
- do ipar = 1,14
- anispara(ipar,1,1) = beta(ipar,icz0,ict0,icp0)
- anispara(ipar,2,1) = beta(ipar,icz1,ict0,icp0)
- anispara(ipar,1,2) = beta(ipar,icz0,ict0,icp1)
- anispara(ipar,2,2) = beta(ipar,icz1,ict0,icp1)
- anispara(ipar,1,3) = beta(ipar,icz0,ict1,icp0)
- anispara(ipar,2,3) = beta(ipar,icz1,ict1,icp0)
- anispara(ipar,1,4) = beta(ipar,icz0,ict1,icp1)
- anispara(ipar,2,4) = beta(ipar,icz1,ict1,icp1)
- enddo
-
-!
-! calculation of distances between the selected point and grid points
-!
- tei = pxy0*ict0 + x0 - pxy0
- fi = pxy0*icp0 + y0 - pxy0
-
-!*** d1=de(tet,ph,tei,fi)
-
- d1 = dsqrt(((tei - tet)**2) + ((fi - ph)**2)*(dsin((tet + tei)*DEGREES_TO_RADIANS/2.)**2))
-
-!*** d2=de(tet,ph,tei+pxy0,fi)
-
- d2 = dsqrt(((tei - tet + pxy0)**2) + ((fi - ph)**2)*(dsin((tet + tei + pxy0)*DEGREES_TO_RADIANS/2.)**2))
-
-!*** d3=de(tet,ph,tei,fi+pxy0)
-
- d3 = dsqrt(((tei - tet)**2) + ((fi - ph + pxy0)**2)*(dsin((tet + tei)*DEGREES_TO_RADIANS/2.)**2))
-
-!*** d4=de(tet,ph,tei+pxy0,fi+pxy0)
-
- d4 = dsqrt(((tei - tet + pxy0)**2) + ((fi - ph + pxy0)**2)*(dsin((tet + tei + pxy0)*DEGREES_TO_RADIANS/2.)**2))
-
- sd = d2*d3*d4 + d1*d2*d4 + d1*d3*d4 + d1*d2*d3
- thickness = pro(icz0) - pro(icz1)
- dprof1 = pro(icz0) - depth
- dprof2 = depth - pro(icz1)
- eps = 0.01
-
- do ipar = 1,14
- if(thickness < eps)then
- pc1 = anispara(ipar,1,1)
- pc2 = anispara(ipar,1,2)
- pc3 = anispara(ipar,1,3)
- pc4 = anispara(ipar,1,4)
- else
- dpr1 = dprof1/thickness
- dpr2 = dprof2/thickness
- pc1 = anispara(ipar,1,1)*dpr2+anispara(ipar,2,1)*dpr1
- pc2 = anispara(ipar,1,2)*dpr2+anispara(ipar,2,2)*dpr1
- pc3 = anispara(ipar,1,3)*dpr2+anispara(ipar,2,3)*dpr1
- pc4 = anispara(ipar,1,4)*dpr2+anispara(ipar,2,4)*dpr1
- endif
- param = pc1*d2*d3*d4 + pc2*d1*d3*d4 + pc3*d1*d2*d4 + pc4*d1*d2*d3
- param = param/sd
- elpar(ipar) = param
- enddo
-
- d11 = ZERO
- d12 = ZERO
- d13 = ZERO
- d14 = ZERO
- d15 = ZERO
- d16 = ZERO
- d22 = ZERO
- d23 = ZERO
- d24 = ZERO
- d25 = ZERO
- d26 = ZERO
- d33 = ZERO
- d34 = ZERO
- d35 = ZERO
- d36 = ZERO
- d44 = ZERO
- d45 = ZERO
- d46 = ZERO
- d55 = ZERO
- d56 = ZERO
- d66 = ZERO
-!
-! create dij
-!
- rho = elpar(1)
- A = elpar(2)
- C = elpar(3)
- F = elpar(4)
- AL = elpar(5)
- AN = elpar(6)
- BC = elpar(7)
- BS = elpar(8)
- GC = elpar(9)
- GS = elpar(10)
- HC = elpar(11)
- HS = elpar(12)
- EC = elpar(13)
- ES = elpar(14)
- C1p = 0.0d0
- S1p = 0.0d0
- C1sv = 0.0d0
- S1sv = 0.0d0
- C1sh = 0.0d0
- S1sh = 0.0d0
- C3 = 0.0d0
- S3 = 0.0d0
-
- d11 = A + EC + BC
- d12 = A - 2.*AN - EC
- d13 = F + HC
- d14 = S3 + 2.*S1sh + 2.*S1p
- d15 = 2.*C1p + C3
- d16 = -BS/2. - ES
- d22 = A + EC - BC
- d23 = F - HC
- d24 = 2.*S1p - S3
- d25 = 2.*C1p - 2.*C1sh - C3
- d26 = -BS/2. + ES
- d33 = C
- d34 = 2.*(S1p - S1sv)
- d35 = 2.*(C1p - C1sv)
- d36 = -HS
- d44 = AL - GC
- d45 = -GS
- d46 = C1sh - C3
- d55 = AL + GC
- d56 = S3 - S1sh
- d66 = AN - EC
-
-! non-dimensionalize the elastic coefficients using
-! the scale of GPa--[g/cm^3][(km/s)^2]
- scaleval = dsqrt(PI*GRAV*RHOAV)
- scale_GPa =(RHOAV/1000.d0)*((R_EARTH*scaleval/1000.d0)**2)
- d11 = d11/scale_GPa
- d12 = d12/scale_GPa
- d13 = d13/scale_GPa
- d14 = d14/scale_GPa
- d15 = d15/scale_GPa
- d16 = d16/scale_GPa
- d22 = d22/scale_GPa
- d23 = d23/scale_GPa
- d24 = d24/scale_GPa
- d25 = d25/scale_GPa
- d26 = d26/scale_GPa
- d33 = d33/scale_GPa
- d34 = d34/scale_GPa
- d35 = d35/scale_GPa
- d36 = d36/scale_GPa
- d44 = d44/scale_GPa
- d45 = d45/scale_GPa
- d46 = d46/scale_GPa
- d55 = d55/scale_GPa
- d56 = d56/scale_GPa
- d66 = d66/scale_GPa
-
-! non-dimensionalize
- rho = rho*1000.d0/RHOAV
-
- end subroutine build_cij
-
-!--------------------------------------------------------------
-
- subroutine read_aniso_mantle_model(AMM_V)
-
- implicit none
-
- include "constants.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
-
- integer nx,ny,np1,np2,ipar,ipa1,ipa,ilat,ilon,il,idep,nfin,nfi0,nf,nri
- double precision xinf,yinf,pxy,ppp,angle,A,A2L,AL,af
- double precision ra(47),pari(14,47)
- double precision bet2(14,34,37,73)
- double precision alph(73,37),ph(73,37)
- character(len=150) glob_prem3sm01, globpreman3sm01
-
- np1 = 1
- np2 = 34
- AMM_V%npar1 = (np2 - np1 + 1)
-
-!
-! glob-prem3sm01: model with rho,A,L,xi-1,1-phi,eta
-!
- call get_value_string(glob_prem3sm01, 'model.glob_prem3sm01', 'DATA/Montagner_model/glob-prem3sm01')
- open(19,file=glob_prem3sm01,status='old',action='read')
-
-!
-! read the models
-!
-! reference model: PREM or ACY400
-!
- call lecmod(nri,pari,ra)
-!
-! read tomographic model (equivalent T.I. model)
-!
- ipa = 0
- nfi0 = 6
- nfin = 14
- do nf = 1,nfi0
- ipa = ipa + 1
- do idep = 1,AMM_V%npar1
- il = idep + np1 - 1
- read(19,"(2f4.0,2i3,f4.0)",end = 88) xinf,yinf,nx,ny,pxy
-
- ppp = 1.
- read(19,"(f5.0,f8.4)",end = 88) AMM_V%pro(idep),ppp
-
- if(nf == 1) pari(nf,il) = ppp
- if(nf == 2) pari(nf,il) = ppp
- if(nf == 3) pari(nf,il) = ppp
- if(nf == 4) ppp = pari(nf,il)
- if(nf == 5) ppp = pari(nf,il)
- do ilat = 1,nx
- read(19,"(17f7.2)",end = 88) (AMM_V%beta(ipa,idep,ilat,ilon),ilon = 1,ny)
-!
-! calculation of A,C,F,L,N
-!
-! bet2(1,...)=rho, bet2(2,...)=A,bet2(3,...)=L,bet2(4,...)=xi
-! bet2(5,...)=phi=C/A, bet2(6,...)=eta=F/A-2L
-! bet2(7,...)=Bc, bet2(8,...)=Bs,bet2(9,...)=Gc,bet2(10,...)=Gs
-! bet2(11,...)=Hc, bet2(12,...)=Hs,bet2(13,...)=Ec,bet2(14,...)=Es
-!
- do ilon = 1,ny
- if(nf <= 3 .or. nf >= 6)then
- bet2(ipa,idep,ilat,ilon) = AMM_V%beta(ipa,idep,ilat,ilon)*0.01*ppp + ppp
- else
- if(nf == 4)bet2(ipa,idep,ilat,ilon) = AMM_V%beta(ipa,idep,ilat,ilon)*0.01 + 1.
- if(nf == 5)bet2(ipa,idep,ilat,ilon) = - AMM_V%beta(ipa,idep,ilat,ilon)*0.01 + 1.
- endif
- enddo
-
- enddo
- enddo
- enddo
-88 close(19)
-
-!
-! read anisotropic azimuthal parameters
-!
-
-!
-! beta(ipa,idep,ilat,ilon) are sorted in (amplitude, phase)
-! normalized, in percents: 100 G/L
-!
- call get_value_string(globpreman3sm01, 'model.globpreman3sm01', 'DATA/Montagner_model/globpreman3sm01')
- open(unit=15,file=globpreman3sm01,status='old',action='read')
-
- do nf = 7,nfin,2
- ipa = nf
- ipa1 = ipa + 1
- do idep = 1,AMM_V%npar1
- il = idep + np1 - 1
- read(15,"(2f4.0,2i3,f4.0)",end = 888) xinf,yinf,nx,ny,pxy
- read(15,"(f5.0,f8.4)",end = 888) AMM_V%pro(idep),ppp
- if(nf == 7) ppp = pari(2,il)
- if(nf == 9) ppp = pari(3,il)
- af = pari(6,il)*(pari(2,il) - 2.*pari(3,il))
- if(nf == 11) ppp = af
- if(nf == 13) ppp = (pari(4,il) + 1.)*pari(3,il)
-
- do ilat = 1,nx
- read(15,"(17f7.2)",end = 888) (alph(ilon,ilat),ilon = 1,ny)
- enddo
-
- do ilat=1,nx
- read(15,"(17f7.2)",end = 888) (ph(ilon,ilat),ilon = 1,ny)
- enddo
-
- do ilat = 1,nx
- do ilon = 1,ny
- angle = 2.*DEGREES_TO_RADIANS*ph(ilon,ilat)
- AMM_V%beta(ipa,idep,ilat,ilon) = alph(ilon,ilat)*ppp*0.01d0
- AMM_V%beta(ipa1,idep,ilat,ilon) = ph(ilon,ilat)
- bet2(ipa,idep,ilat,ilon) = alph(ilon,ilat)*dcos(angle)*ppp*0.01d0
- bet2(ipa1,idep,ilat,ilon) = alph(ilon,ilat)*dsin(angle)*ppp*0.01d0
- enddo
- enddo
-
- enddo
- enddo
-
-888 close(15)
-
- do idep = 1,AMM_V%npar1
- do ilat = 1,nx
- do ilon = 1,ny
-
-! rho
- AMM_V%beta(1,idep,ilat,ilon) = bet2(1,idep,ilat,ilon)
-
-! A
- AMM_V%beta(2,idep,ilat,ilon) = bet2(2,idep,ilat,ilon)
- A=bet2(2,idep,ilat,ilon)
-
-! C
- AMM_V%beta(3,idep,ilat,ilon) = bet2(5,idep,ilat,ilon)*A
-
-! F
- A2L = A - 2.*bet2(3,idep,ilat,ilon)
- AMM_V%beta(4,idep,ilat,ilon) = bet2(6,idep,ilat,ilon)*A2L
-
-! L
- AMM_V%beta(5,idep,ilat,ilon) = bet2(3,idep,ilat,ilon)
- AL = bet2(3,idep,ilat,ilon)
-
-! N
- AMM_V%beta(6,idep,ilat,ilon) = bet2(4,idep,ilat,ilon)*AL
-
-! azimuthal terms
- do ipar = 7,14
- AMM_V%beta(ipar,idep,ilat,ilon) = bet2(ipar,idep,ilat,ilon)
- enddo
-
- enddo
- enddo
- enddo
-
- end subroutine read_aniso_mantle_model
-
-!--------------------------------------------------------------------
-
- subroutine lecmod(nri,pari,ra)
-
- implicit none
-
-! read the reference Earth model: rho, Vph, Vsv, XI, PHI, ETA
-! array par(i,nlayer)
-! output: array pari(ipar, nlayer): rho, A, L, xi-1, phi-1, eta-1
-
- integer i,j,k,ip,ifanis,idum1,idum2,idum3,nlayer,nout,neff,&
- nband,nri,minlay,moho,kiti
- double precision pari(14,47),qkappa(47),qshear(47),par(6,47)
- double precision epa(14,47),ra(47),dcori(47),ri(47)
- double precision corpar(21,47)
- double precision aa,an,al,af,ac,vpv,vph,vsv,vsh,rho,red,a2l
- character(len=80) null
- character(len=150) Adrem119
-
- ifanis = 1
- nri = 47
-
- call get_value_string(Adrem119, 'model.Adrem119', 'DATA/Montagner_model/Adrem119')
- open(unit=13,file=Adrem119,status='old',action='read')
- read(13,*,end = 77) nlayer,minlay,moho,nout,neff,nband,kiti,null
-
- if(kiti == 0) read(13,"(20a4)",end = 77) idum1
- read(13,"(20a4)",end = 77) idum2
- read(13,"(20a4)",end = 77) idum3
-
- do i = 1,nlayer
- read(13,"(4x,f11.1,8d12.5)",end = 77) ra(i),(par(k,i),k = 1,6),qshear(i),qkappa(i)
- enddo
-
- do i = 1,nlayer
- ri(i) = 0.001*ra(i)
- enddo
-
- do i = 1,nlayer
- rho = par(1,i)
- pari(1,i) = rho
-! A : pari(2,i)
- pari(2,i) = rho*(par(2,i)**2)
- aa = pari(2,i)
-! L : pari(3,i)
- pari(3,i) = rho*(par(3,i)**2)
- al = pari(3,i)
-! Xi : pari(4,i)= (N-L)/L
- an = al*par(4,i)
- pari(4,i) = 0.
- pari(4,i) = par(4,i) - 1.
-! Phi : pari(5,i)=(a-c)/a
- pari(5,i) = - par(5,i) + 1.
- ac = par(5,i)*aa
-! f : pari(4,i)
- af = par(6,i)*(aa - 2.*al)
- pari(6,i) = par(6,i)
- do ip = 7,14
- pari(ip,i) = 0.
- enddo
- vsv = 0.
- vsh = 0.
- if(al < 0.0001 .or. an < 0.0001) goto 12
- vsv = dsqrt(al/rho)
- vsh = dsqrt(an/rho)
- 12 vpv = dsqrt(ac/rho)
- vph = dsqrt(aa/rho)
- enddo
-
- red = 1.
- do i = 1,nlayer
- read(13,"(15x,6e12.5,f11.1)",end = 77) (epa(j,i),j = 1,6),dcori(i)
- epa(7,i) = epa(2,i)
- epa(8,i) = epa(2,i)
- epa(9,i) = epa(3,i)
- epa(10,i) = epa(3,i)
-
- a2l = pari(2,i) - 2.*pari(3,i)
- epa(11,i) = epa(6,i)*a2l
- epa(12,i) = epa(6,i)*a2l
- epa(13,i) = epa(3,i)
- epa(14,i) = epa(3,i)
-
- do j = 1,14
- epa(j,i) = red*epa(j,i)
- enddo
-
- read(13,"(21f7.3)",end = 77) (corpar(j,i),j = 1,21)
-
- enddo
-
-77 close(13)
-
- end subroutine lecmod
-
-!--------------------------------------------------------------------
-
- subroutine rotate_aniso_tensor(theta,phi,d11,d12,d13,d14,d15,d16,&
- d22,d23,d24,d25,d26,&
- d33,d34,d35,d36,d44,d45,d46,d55,d56,d66,&
- c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
- c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
-
- implicit none
-
- include "constants.h"
-
- double precision theta,phi
- double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26, &
- c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
- double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
- d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
- double precision costheta,sintheta,cosphi,sinphi
- double precision costhetasq,sinthetasq,cosphisq,sinphisq
- double precision costwotheta,sintwotheta,costwophi,sintwophi
- double precision cosfourtheta,sinfourtheta
- double precision costhetafour,sinthetafour,cosphifour,sinphifour
- double precision sintwophisq,sintwothetasq
-
- costheta = dcos(theta)
- sintheta = dsin(theta)
- cosphi = dcos(phi)
- sinphi = dsin(phi)
-
- costhetasq = costheta * costheta
- sinthetasq = sintheta * sintheta
- cosphisq = cosphi * cosphi
- sinphisq = sinphi * sinphi
-
- costhetafour = costhetasq * costhetasq
- sinthetafour = sinthetasq * sinthetasq
- cosphifour = cosphisq * cosphisq
- sinphifour = sinphisq * sinphisq
-
- costwotheta = dcos(2.d0*theta)
- sintwotheta = dsin(2.d0*theta)
- costwophi = dcos(2.d0*phi)
- sintwophi = dsin(2.d0*phi)
-
- cosfourtheta = dcos(4.d0*theta)
- sinfourtheta = dsin(4.d0*theta)
- sintwothetasq = sintwotheta * sintwotheta
- sintwophisq = sintwophi * sintwophi
-
-! recompute 21 anisotropic coefficients for full anisotropoc model using Mathematica
-
-c11 = d22*sinphifour - 2.*sintwophi*sinphisq*(d26*costheta + d24*sintheta) - &
- 2.*cosphisq*sintwophi*(d16*costhetasq*costheta + &
- (d14 + 2*d56)*costhetasq*sintheta + &
- (d36 + 2*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
- cosphifour*(d11*costhetafour + 2.*d15*costhetasq*sintwotheta + &
- (d13 + 2.*d55)*sintwothetasq/2. + &
- 2.*d35*sintwotheta*sinthetasq + d33*sinthetafour) + &
- (sintwophisq/4.)*(d12 + d23 + 2.*(d44 + d66) + &
- (d12 - d23 - 2.*d44 + 2.*d66)*costwotheta + &
- 2.*(d25 + 2.*d46)*sintwotheta)
-
-c12 = -((sintwophi/2.)*sinphisq*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
- (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
- 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
- (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/2. + &
- cosphisq*sintwophi*(d16*costhetasq*costheta - d24*sintheta + &
- (d14 + 2.*d56)*costhetasq*sintheta + d34*sintheta*sinthetasq + &
- costheta*(-d26 + (d36 + 2.*d45)*sinthetasq)) + &
- (sintwophisq/4.)*(d22 + d11*costhetafour + &
- 2.*d15*costhetasq*sintwotheta - 4.*d44*sinthetasq + &
- d33*sinthetafour + costhetasq*(-4.*d66 + &
- 2.*(d13 + 2.*d55)*sinthetasq) + &
- costheta*(-8.*d46*sintheta + 4.*d35*sintheta*sinthetasq)) + &
- (cosphifour + sinphifour)*(d12*costhetasq + &
- d23*sinthetasq + d25*sintwotheta)
-
-c13 = sinphisq*(d23*costhetasq - d25*sintwotheta + d12*sinthetasq) - &
- sintwophi*(d36*costhetasq*costheta + &
- (d34 - 2.*d56)*costhetasq*sintheta + &
- (d16 - 2.*d45)*costheta*sinthetasq + d14*sintheta*sinthetasq) + &
- (cosphisq*(d11 + 6.*d13 + d33 - 4.*d55 - &
- (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + &
- 4.*(-d15 + d35)*sinfourtheta))/8.
-
-c14 = (-4.*cosphi*sinphisq*((-d14 - 2.*d24 + d34 + 2.*d56)*costheta + &
- (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) + &
- 2.*(-d16 + d26 + d36 + (-d16 + d36 + 2.*d45)*costwotheta)*sintheta) + &
- 8.*cosphisq*cosphi*(d14*costhetasq*costheta - &
- (d16 - 2.*d45)*costhetasq*sintheta + &
- (d34 - 2.*d56)*costheta*sinthetasq - d36*sintheta*sinthetasq) + &
- 4.*sinphi*sinphisq*(2.*d25*costwotheta + (-d12 + d23)*sintwotheta) + &
- cosphisq*sinphi*(4.*(d15 + d35 - 4*d46)*costwotheta + &
- 4.*(d15 - d35)*cosfourtheta - &
- 2.*(d11 - d33 + 4.*d44 - 4.*d66 + &
- (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta))/8.
-
-c15 = (8.*sinphi*sinphisq*(-(d24*costheta) + d26*sintheta) + &
- 4.*cosphi*sinphisq*(2.*(d25 + 2.*d46)*costwotheta + &
- (-d12 + d23 + 2.*d44 - 2.*d66)*sintwotheta) + &
- cosphisq*cosphi*(4.*(d15 + d35)*costwotheta + &
- 4.*(d15 - d35)*cosfourtheta - 2.*(d11 - d33 + &
- (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta) - &
- 2.*cosphisq*sinphi*((d14 + 3.*d34 + 2.*d56)*costheta + &
- 3.*(d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
- (3.*d16 + d36 + 2.*d45)*sintheta + &
- 3.*(-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
-
-c16 = -(sinphifour*(d26*costheta + d24*sintheta)) - &
- (3.*(sintwophisq/4.)*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
- (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
- 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
- (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/4. + &
- cosphifour*(d16*costhetasq*costheta + &
- (d14 + 2.*d56)*costhetasq*sintheta + &
- (d36 + 2.*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
- (sintwophi/2.)*sinphisq*(-d22 + (d12 + 2.*d66)*costhetasq + &
- 2.*d46*sintwotheta + (d23 + 2.*d44)*sinthetasq + d25*sintwotheta) + &
- cosphisq*(sintwophi/2.)*(d11*costhetafour + &
- 2.*d15*costhetasq*sintwotheta - (d23 + 2.*d44)*sinthetasq + &
- d33*sinthetafour - costhetasq*(d12 + &
- 2.*d66 - 2.*(d13 + 2.*d55)*sinthetasq) - &
- (d25 - d35 + 2.*d46 + d35*costwotheta)*sintwotheta)
-
-c22 = d22*cosphifour + 2.*cosphisq*sintwophi*(d26*costheta + d24*sintheta) + &
- 2.*sintwophi*sinphisq*(d16*costhetasq*costheta + &
- (d14 + 2.*d56)*costhetasq*sintheta + &
- (d36 + 2.*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
- sinphifour*(d11*costhetafour + 2.*d15*costhetasq*sintwotheta + &
- (d13 + 2.*d55)*sintwothetasq/2. + &
- 2.*d35*sintwotheta*sinthetasq + d33*sinthetafour) + &
- (sintwophisq/4.)*(d12 + d23 + 2.*(d44 + d66) + &
- (d12 - d23 - 2.*d44 + 2.*d66)*costwotheta + &
- 2.*(d25 + 2.*d46)*sintwotheta)
-
-c23 = d13*costhetafour*sinphisq + &
- sintheta*sinthetasq*(d14*sintwophi + d13*sinphisq*sintheta) + &
- costheta*sinthetasq*((d16 - 2.*d45)*sintwophi + &
- 2.*(d15 - d35)*sinphisq*sintheta) + &
- costhetasq*costheta*(d36*sintwophi + &
- 2.*(-d15 + d35)*sinphisq*sintheta) + &
- costhetasq*sintheta*((d34 - 2.*d56)*sintwophi + &
- (d11 + d33 - 4.*d55)*sinphisq*sintheta) + &
- cosphisq*(d23*costhetasq - d25*sintwotheta + d12*sinthetasq)
-
-c24 = (8.*cosphisq*cosphi*(d24*costheta - d26*sintheta) + &
- 4.*cosphisq*sinphi*(2.*(d25 + 2.*d46)*costwotheta + &
- (-d12 + d23 + 2.*d44 - 2.*d66)*sintwotheta) + &
- sinphi*sinphisq*(4.*(d15 + d35)*costwotheta + &
- 4.*(d15 - d35)*cosfourtheta - &
- 2.*(d11 - d33 + (d11 - 2.*d13 + &
- d33 - 4.*d55)*costwotheta)*sintwotheta) + &
- 2.*cosphi*sinphisq*((d14 + 3.*d34 + 2.*d56)*costheta + &
- 3.*(d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
- (3.*d16 + d36 + 2.*d45)*sintheta + &
- 3.*(-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
-
-c25 = (4.*cosphisq*sinphi*((-d14 - 2.*d24 + d34 + 2.*d56)*costheta + &
- (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) + &
- 2.*(-d16 + d26 + d36 + (-d16 + d36 + 2.*d45)*costwotheta)*sintheta) - &
- 8.*sinphi*sinphisq*(d14*costhetasq*costheta - &
- (d16 - 2.*d45)*costhetasq*sintheta + &
- (d34 - 2.*d56)*costheta*sinthetasq - d36*sintheta*sinthetasq) + &
- 4.*cosphisq*cosphi*(2.*d25*costwotheta + (-d12 + d23)*sintwotheta) + &
- cosphi*sinphisq*(4.*(d15 + d35 - 4.*d46)*costwotheta + &
- 4.*(d15 - d35)*cosfourtheta - 2.*(d11 - d33 + 4.*d44 - 4.*d66 + &
- (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta))/8.
-
-c26 = cosphifour*(d26*costheta + d24*sintheta) + &
- (3.*(sintwophisq/4.)*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
- (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
- 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
- (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/4. - &
- sinphifour*(d16*costhetasq*costheta + &
- (d14 + 2.*d56)*costhetasq*sintheta + &
- (d36 + 2.*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
- cosphisq*(sintwophi/2.)*(-d22 + (d12 + 2.*d66)*costhetasq + &
- 2.*d46*sintwotheta + (d23 + 2.*d44)*sinthetasq + &
- d25*sintwotheta) + (sintwophi/2.)*sinphisq*(d11*costhetafour + &
- 2.*d15*costhetasq*sintwotheta - (d23 + 2.*d44)*sinthetasq + &
- d33*sinthetafour - costhetasq*(d12 + &
- 2.*d66 - 2.*(d13 + 2.*d55)*sinthetasq) - &
- (d25 - d35 + 2.*d46 + d35*costwotheta)*sintwotheta)
-
-c33 = d33*costhetafour - 2.*d35*costhetasq*sintwotheta + &
- (d13 + 2.*d55)*sintwothetasq/2. - &
- 2.*d15*sintwotheta*sinthetasq + d11*sinthetafour
-
-c34 = cosphi*(d34*costhetasq*costheta - (d36 + 2.*d45)*costhetasq*sintheta + &
- (d14 + 2.*d56)*costheta*sinthetasq - d16*sintheta*sinthetasq) + &
- (sinphi*(4.*(d15 + d35)*costwotheta + 4.*(-d15 + d35)*cosfourtheta + &
- 2.*(-d11 + d33)*sintwotheta + &
- (d11 - 2.*d13 + d33 - 4.*d55)*sinfourtheta))/8.
-
-c35 = sinphi*(-(d34*costhetasq*costheta) + &
- (d36 + 2.*d45)*costhetasq*sintheta - &
- (d14 + 2.*d56)*costheta*sinthetasq + d16*sintheta*sinthetasq) + &
- (cosphi*(4.*(d15 + d35)*costwotheta + 4.*(-d15 + d35)*cosfourtheta + &
- 2.*(-d11 + d33)*sintwotheta + &
- (d11 - 2.*d13 + d33 - 4.*d55)*sinfourtheta))/8.
-
-c36 = (4.*costwophi*((d16 + 3.*d36 - 2.*d45)*costheta + &
- (-d16 + d36 + 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
- (3.*d14 + d34 - 2.*d56)*sintheta + &
- (-d14 + d34 - 2.*d56)*(-4.*sinthetasq*sintheta + 3.*sintheta)) + &
- sintwophi*(d11 - 4.*d12 + 6.*d13 - 4.*d23 + d33 - 4.*d55 + &
- 4.*(d12 - d23)*costwotheta - &
- (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + &
- 8.*d25*sintwotheta + 4.*(-d15 + d35)*sinfourtheta))/16.
-
-c44 = (d11 - 2.*d13 + d33 + 4.*(d44 + d55 + d66) - &
- (d11 - 2.*d13 + d33 - 4.*(d44 - d55 + d66))*costwophi + &
- 4.*sintwophi*((d16 - d36 + 2.*d45)*costheta + &
- (-d16 + d36 + 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) - &
- 2.*(d14 - d34 + (d14 - d34 + 2.*d56)*costwotheta)*sintheta) + &
- 8.*cosphisq*((d44 - d66)*costwotheta - 2.*d46*sintwotheta) + &
- 2.*sinphisq*(-((d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta) + &
- 4.*(-d15 + d35)*sinfourtheta))/16.
-
-c45 = (4.*costwophi*((d16 - d36 + 2.*d45)*costheta + &
- (-d16 + d36 + 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) - &
- 2.*(d14 - d34 + (d14 - d34 + 2.*d56)*costwotheta)*sintheta) + &
- sintwophi*(d11 - 2.*d13 + d33 - 4.*(d44 - d55 + d66) + &
- 4.*(-d44 + d66)*costwotheta - &
- (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + 8.*d46*sintwotheta + &
- 4.*(-d15 + d35)*sinfourtheta))/16.
-
-c46 = (-2.*sinphi*sinphisq*((-d14 + d34 + 2.*d56)*costheta + &
- (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) + &
- 2.*(-d16 + d36 + (-d16 + d36 + 2.*d45)*costwotheta)*sintheta) + &
- 4.*cosphisq*cosphi*(2.*d46*costwotheta + (d44 - d66)*sintwotheta) + &
- cosphi*sinphisq*(4.*(d15 - 2.*d25 + d35 - 2.*d46)*costwotheta + &
- 4.*(d15 - d35)*cosfourtheta - &
- 2.*(d11 - 2.*d12 + 2.*d23 - d33 + 2.*d44 - 2.*d66 + &
- (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta) + &
- 4.*cosphisq*sinphi*((d14 - 2.*d24 + d34)*costheta + &
- (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
- (d16 - 2.*d26 + d36)*sintheta + &
- (-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
-
-c55 = d66*sinphisq*sinthetasq + (sintwotheta/2.)*(-2.*d46*sinphisq + &
- (d36 + d45)*sintwophi*sintheta) + &
- costhetasq*(d44*sinphisq + (d14 + d56)*sintwophi*sintheta) - &
- sintwophi*(d45*costhetasq*costheta + d34*costhetasq*sintheta + &
- d16*costheta*sinthetasq + d56*sintheta*sinthetasq) + &
- (cosphisq*(d11 - 2.*d13 + d33 + 4.*d55 - &
- (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + &
- 4.*(-d15 + d35)*sinfourtheta))/8.
-
-c56 = (8.*cosphisq*cosphi*(d56*costhetasq*costheta - &
- (d16 - d36 - d45)*costhetasq*sintheta - &
- (d14 - d34 + d56)*costheta*sinthetasq - d45*sintheta*sinthetasq) + &
- 4.*sinphi*sinphisq*(2.*d46*costwotheta + (d44 - d66)*sintwotheta) + &
- cosphisq*sinphi*(4.*(d15 - 2.*d25 + d35 - 2.*d46)*costwotheta + &
- 4.*(d15 - d35)*cosfourtheta - &
- 2.*(d11 - 2.*d12 + 2.*d23 - d33 + 2.*d44 - 2.*d66 + &
- (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta) - &
- 4.*cosphi*sinphisq*((d14 - 2.*d24 + d34)*costheta + &
- (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
- (d16 - 2.*d26 + d36)*sintheta + &
- (-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
-
-c66 = -((sintwophi/2.)*sinphisq*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
- (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
- 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
- (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/2. + &
- cosphisq*sintwophi*(d16*costhetasq*costheta - d24*sintheta + &
- (d14 + 2.*d56)*costhetasq*sintheta + d34*sintheta*sinthetasq + &
- costheta*(-d26 + (d36 + 2.*d45)*sinthetasq)) + &
- (sintwophisq/4.)*(d22 + d11*costhetafour + &
- 2.*d15*costhetasq*sintwotheta - 2.*(d23 + d44)*sinthetasq + &
- d33*sinthetafour - 2.*sintwotheta*(d25 + d46 - d35*sinthetasq) - &
- 2.*costhetasq*(d12 + d66 - (d13 + 2.*d55)*sinthetasq)) + &
- (cosphifour + sinphifour)*(d66*costhetasq + &
- d44*sinthetasq + d46*sintwotheta)
-
-
-end subroutine rotate_aniso_tensor
-!--------------------------------------------------------------------
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_central_cube.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_central_cube.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_central_cube.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -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 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_scalar.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_scalar.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_scalar.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -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 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_vector.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_vector.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -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 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 "OUTPUT_FILES/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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/attenuation_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/attenuation_model.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/attenuation_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,1904 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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>.
-! <savage13 at gps.caltech.edu>
-! <savage13 at dtm.ciw.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(:), pointer :: 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
-
- 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(:)
- end if
-
- 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(:)
- end do
-
-end subroutine attenuation_model_setup
-
-subroutine attenuation_save_arrays(prname, 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(:), pointer :: 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
- character(len=150) prname
- integer ier
- integer myrank
- integer, save :: first_time_called = 1
-
- 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=prname(1:len_trim(prname))//'1D_Q.bin',status='unknown',form='unformatted')
- 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(:), pointer :: 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(:), pointer :: 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
-
- allocate(AM_V%Qtau_s(N_SLS))
-
- 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, prname, 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(:), pointer :: 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
- character(len=150) prname
- 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
-
- if(myrank == 0 .AND. iregion_code == IREGION_CRUST_MANTLE .AND. first_time_called == 1) then
- first_time_called = 0
- open(unit=27, file=prname(1:len_trim(prname))//'1D_Q.bin', status='unknown', form='unformatted')
- 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)
-
- call MPI_BARRIER(MPI_COMM_WORLD, ier)
-
-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(:), pointer :: 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(:), pointer :: 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, prname, one_minus_sum_beta, factor_common, scale_factor, tau_s, vnspec)
-
- implicit none
-
- include 'constants.h'
-
- integer myrank, vnspec
- character(len=150) prname
- 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
-
- open(unit=27, file=prname(1:len_trim(prname))//'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, prnt, 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
-! write(*,*)j,tau_s(j),tau_e(j)
- 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)
- end do
-! write(*,*)A(i),B(i),10**f(i)
- 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 copied from Matlab fminsearch.m
-! and modified to suit my nefarious 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)
-! prnt = Input
-! 3 => report every iteration
-! 4 => report every iteration, total simplex
-! err = Output
-! 0 => Normal exeecution, converged within desired range
-! 1 => Function Evaluation exceeded limit
-! 2 => Iterations exceeded limit
-!
-! See Matlab fminsearch
-subroutine fminsearch(funk, x, n, itercount, tolf, prnt, 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, prnt, 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
- if(prnt == 3) then
- write(*,*)'Iterations Funk Evals Value How'
- write(*,*)itercount, func_evals, fv(1), how
- endif
- if(prnt == 4) then
- write(*,*)'How: ',how
- write(*,*)'V: ', v
- write(*,*)'fv: ',fv
- write(*,*)'evals: ',func_evals
- endif
-
- do while (func_evals < maxfun .AND. itercount < maxiter)
-
- if(max_size_simplex(v,n) <= tolx .AND. &
- max_value(fv,n+1) <= tolf) then
- goto 666
- 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
- if (prnt == 3) then
- write(*,*)itercount, func_evals, fv(1), how
- elseif (prnt == 4) then
- write(*,*)
- write(*,*)'How: ',how
- write(*,*)'v: ',v
- write(*,*)'fv: ',fv
- write(*,*)'evals: ',func_evals
- endif
- enddo
-
- if(func_evals > maxfun) then
- write(*,*)'function evaluations exceeded prescribed limit', maxfun
- err = 1
- endif
- if(itercount > maxiter) then
- write(*,*)'iterations exceeded prescribed limit', maxiter
- err = 2
- endif
-
-666 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
- end do
- 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
- write(*,*)'iflag:',iflag
- 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/auto_ner.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/auto_ner.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/auto_ner.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,500 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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>.
-! <savage13 at gps.caltech.edu>
-! <savage13 at dtm.ciw.edu>
-!
-! It is based partially upon formulation in:
-!
-! @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}}
-!
-! and the core determination was developed.
-!
-
- subroutine auto_time_stepping(WIDTH, NEX_MAX, DT)
- implicit none
-
- include 'constants.h'
-
- integer NEX_MAX
- double precision DT, WIDTH
- double precision RADIAL_LEN_RATIO_CENTRAL_CUBE
- double precision RADIUS_INNER_CORE
- double precision DOUBLING_INNER_CORE
- double precision P_VELOCITY_MAX ! Located Near the inner Core Boundary
- double precision MAXIMUM_STABILITY_CONDITION
- double precision MIN_GLL_POINT_SPACING_5
-
- RADIAL_LEN_RATIO_CENTRAL_CUBE = 0.40d0
- MAXIMUM_STABILITY_CONDITION = 0.40d0
- RADIUS_INNER_CORE = 1221.0d0
- DOUBLING_INNER_CORE = 8.0d0
- P_VELOCITY_MAX = 11.02827d0
- MIN_GLL_POINT_SPACING_5 = 0.1730d0
-
- DT = ( RADIAL_LEN_RATIO_CENTRAL_CUBE * ((WIDTH * (PI / 180.0d0)) * RADIUS_INNER_CORE) / &
- ( dble(NEX_MAX) / DOUBLING_INNER_CORE ) / P_VELOCITY_MAX) * &
- MIN_GLL_POINT_SPACING_5 * MAXIMUM_STABILITY_CONDITION
-
- end subroutine auto_time_stepping
-
- subroutine auto_attenuation_periods(WIDTH, NEX_MAX, MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
- implicit none
-
- include 'constants.h'
-
- integer NEX_MAX, MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD
- double precision WIDTH, TMP
- double precision GLL_SPACING, PTS_PER_WAVELENGTH
- double precision S_VELOCITY_MIN, DEG2KM
- double precision THETA(5)
-
- GLL_SPACING = 4.00d0
- PTS_PER_WAVELENGTH = 4.00d0
- S_VELOCITY_MIN = 2.25d0
- DEG2KM = 111.00d0
-
- ! THETA defines the width of the Attenation Range in Decades
- ! The number defined here were determined by minimizing
- ! the "flatness" of the absoption spectrum. Each THETA
- ! is defined for a particular N_SLS (constants.h)
- ! THETA(2) is for N_SLS = 2
- THETA(1) = 0.00d0
- THETA(2) = 0.75d0
- THETA(3) = 1.75d0
- THETA(4) = 2.25d0
- THETA(5) = 2.85d0
-
- ! Compute Min Attenuation Period
- !
- ! The Minimum attenuation period = (Grid Spacing in km) / V_min
- ! Grid spacing in km = Width of an element in km * spacing for GLL point * points per wavelength
- ! Width of element in km = (Angular width in degrees / NEX_MAX) * degrees to km
-
- TMP = (WIDTH / ( GLL_SPACING * dble(NEX_MAX)) * DEG2KM * PTS_PER_WAVELENGTH ) / &
- S_VELOCITY_MIN
- 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')
- endif
-
- ! Compute Max Attenuation Period
- !
- ! The max attenuation period for 3 SLS is optimally
- ! 1.75 decades from the min attenuation period, see THETA above
- TMP = TMP * 10.0d0**THETA(N_SLS)
- MAX_ATTENUATION_PERIOD = TMP
-
- end subroutine auto_attenuation_periods
-
- subroutine auto_ner(WIDTH, 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)
-
- implicit none
-
- include 'constants.h'
-
- double precision WIDTH
- integer NEX_MAX
- integer NER_CRUST, NER_80_MOHO, NER_220_80, NER_400_220, NER_600_400, &
- NER_670_600, NER_771_670, NER_TOPDDOUBLEPRIME_771, &
- NER_CMB_TOPDDOUBLEPRIME, NER_OUTER_CORE, NER_TOP_CENTRAL_CUBE_ICB
- double precision R_CENTRAL_CUBE
- logical CASE_3D
-
- integer, parameter :: NUM_REGIONS = 14
- integer, dimension(NUM_REGIONS) :: scaling
- double precision, dimension(NUM_REGIONS) :: radius
- double precision, dimension(NUM_REGIONS-1) :: ratio_top
- double precision, dimension(NUM_REGIONS-1) :: ratio_bottom
- integer, dimension(NUM_REGIONS-1) :: NER
- integer NEX_ETA
-
- ! This is PREM in Kilometers, well ... kinda, not really ....
- radius(1) = 6371.00d0 ! Surface
- radius(2) = 6346.60d0 ! Moho - 1st Mesh Doubling Interface
- radius(3) = 6291.60d0 ! 80
- radius(4) = 6151.00d0 ! 220
- radius(5) = 5971.00d0 ! 400
- radius(6) = 5771.00d0 ! 600
- radius(7) = 5701.00d0 ! 670
- radius(8) = 5600.00d0 ! 771
- radius(9) = 4712.00d0 ! 1650 - 2nd Mesh Doubling: Geochemical Layering; Kellogg et al. 1999, Science
- radius(10) = 3630.00d0 ! D''
- radius(11) = 3480.00d0 ! CMB
- radius(12) = 2511.00d0 ! 3860 - 3rd Mesh Doubling Interface
- radius(13) = 1371.00d0 ! 5000 - 4th Mesh Doubling Interface
- radius(14) = 982.00d0 ! Top Central Cube
-
- call find_r_central_cube(NEX_MAX, radius(14), NEX_ETA)
-
- ! Mesh Doubling
- scaling(1) = 1 ! SURFACE TO MOHO
- scaling(2:8) = 2 ! MOHO TO G'' (Geochemical Mantle 1650)
- scaling(9:11) = 4 ! G'' TO MIC (Middle Inner Core)
- scaling(12) = 8 ! MIC TO MIC-II
- scaling(13:14) = 16 ! MIC-II TO Central Cube -> Center of the Earth
-
- ! Minimum Number of Elements a Region must have
- NER(:) = 1
- NER(3:5) = 2
- if(CASE_3D) then
- NER(1) = 2
- endif
-
- ! Find the Number of Radial Elements in a region based upon
- ! the aspect ratio of the elements
- call auto_optimal_ner(NUM_REGIONS, WIDTH, NEX_MAX, radius, scaling, NER, ratio_top, ratio_bottom)
-
- ! Set Output arguments
- NER_CRUST = NER(1)
- NER_80_MOHO = NER(2)
- NER_220_80 = NER(3)
- NER_400_220 = NER(4)
- NER_600_400 = NER(5)
- NER_670_600 = NER(6)
- NER_771_670 = NER(7)
- NER_TOPDDOUBLEPRIME_771 = NER(8) + NER(9)
- NER_CMB_TOPDDOUBLEPRIME = NER(10)
- NER_OUTER_CORE = NER(11) + NER(12)
- NER_TOP_CENTRAL_CUBE_ICB = NER(13)
- R_CENTRAL_CUBE = radius(14) * 1000.0d0
-
- end subroutine auto_ner
-
- subroutine auto_optimal_ner(NUM_REGIONS, width, NEX, r, scaling, NER, rt, rb)
-
- implicit none
-
- include 'constants.h'
-
- integer NUM_REGIONS
- integer NEX
- double precision width ! Width of the Chunk in Degrees
- integer, dimension(NUM_REGIONS-1) :: NER ! Elements per Region - IN-N-OUT - Yummy !
- integer, dimension(NUM_REGIONS) :: scaling ! Element Doubling - INPUT
- double precision, dimension(NUM_REGIONS) :: r ! Radius - INPUT
- double precision, dimension(NUM_REGIONS-1) :: rt ! Ratio at Top - OUTPUT
- double precision, dimension(NUM_REGIONS-1) :: rb ! Ratio at Bottom - OUTPUT
-
- double precision dr, w, ratio, xi, ximin, wt, wb
- integer ner_test
- integer i
-
- ! Find optimal elements per region
- do i = 1,NUM_REGIONS-1
- dr = r(i) - r(i+1) ! Radial Length of Ragion
- wt = width * PI/180.0d0 * r(i) / (NEX*1.0d0 / scaling(i)*1.0d0) ! Element Width Top
- wb = width * PI/180.0d0 * r(i+1) / (NEX*1.0d0 / scaling(i)*1.0d0) ! Element Width Bottom
- w = (wt + wb) * 0.5d0 ! Average Width of Region
- ner_test = NER(i) ! Initial solution
- ratio = (dr / ner_test) / w ! Aspect Ratio of Element
- xi = dabs(ratio - 1.0d0) ! Aspect Ratio should be near 1.0
- ximin = 1e7 ! Initial Minimum
-
- do while(xi <= ximin)
- NER(i) = ner_test ! Found a better solution
- ximin = xi !
- ner_test = ner_test + 1 ! Increment ner_test and
- ratio = (dr / ner_test) / w ! look for a better
- xi = dabs(ratio - 1.0d0) ! solution
- end do
- rt(i) = dr / NER(i) / wt ! Find the Ratio of Top
- rb(i) = dr / NER(i) / wb ! and Bottom for completeness
- end do
-
- end subroutine auto_optimal_ner
-
- subroutine find_r_central_cube(nex_xi_in, rcube, nex_eta_in)
- implicit none
-
- integer, parameter :: NBNODE = 8
- double precision, parameter :: alpha = 0.41d0
-
- integer npts
- integer nex_xi, nex_eta_in, nex_xi_in
- integer nex_eta
- double precision rcube, rcubestep, rcube_test, rcubemax
- double precision xi, ximin
- double precision , allocatable, dimension(:,:) :: points
- double precision elem(NBNODE+1, 2)
- integer nspec_cube, nspec_chunks, ispec, nspec
- double precision edgemax, edgemin
- double precision max_edgemax, min_edgemin
- double precision aspect_ratio, max_aspect_ratio
-
- nex_xi = nex_xi_in / 16
-
-
- rcubestep = 1.0d0
- rcube_test = 930.0d0
- rcubemax = 1100.0d0
- nex_eta_in = -1
- ximin = 1e7
- rcube = rcube_test
-
- do while(rcube_test <= rcubemax)
- max_edgemax = -1e7
- min_edgemin = 1e7
- max_aspect_ratio = 0.0d0
- call compute_nex(nex_xi, rcube_test, alpha, nex_eta)
- npts = (4 * nex_xi * nex_eta * NBNODE) + (nex_xi * nex_xi * NBNODE)
- allocate(points(npts, 2))
- call compute_IC_mesh(rcube_test, points, npts, nspec_cube, nspec_chunks, nex_xi, nex_eta)
- nspec = nspec_cube + nspec_chunks
- do ispec = 1,nspec
- call get_element(points, ispec, npts, elem)
- call get_size_min_max(elem, edgemax, edgemin)
- aspect_ratio = edgemax / edgemin
- max_edgemax = MAX(max_edgemax, edgemax)
- min_edgemin = MIN(min_edgemin, edgemin)
- max_aspect_ratio = MAX(max_aspect_ratio, aspect_ratio)
- end do
- xi = (max_edgemax / min_edgemin)
-! xi = abs(rcube_test - 981.0d0) / 45.0d0
-! write(*,'(a,5(f14.4,2x))')'rcube, xi, ximin:-',rcube_test, xi, min_edgemin,max_edgemax,max_aspect_ratio
- deallocate(points)
- if(xi < ximin) then
- ximin = xi
- rcube = rcube_test
- nex_eta_in = nex_eta
- endif
- rcube_test = rcube_test + rcubestep
- enddo
-
- end subroutine find_r_central_cube
-
- subroutine compute_nex(nex_xi, rcube, alpha, ner)
- implicit none
-
- double precision, parameter :: RICB_KM = 1221.0d0
- double precision, parameter :: PI = 3.1415
-
- integer nex_xi, ner
- double precision rcube, alpha
- integer ix
- double precision ratio_x, factx, xi
- double precision x, y
- double precision surfx, surfy
- double precision dist_cc_icb, somme, dist_moy
-
- somme = 0.0d0
-
- do ix = 0,nex_xi/2,1
- ratio_x = (ix * 1.0d0) / ( nex_xi * 1.0d0)
- factx = 2.0d0 * ratio_x - 1.0d0
- xi = (PI / 2.0d0) * factx
- x = (rcube / sqrt(2.0d0)) * factx
- y = (rcube / sqrt(2.0d0)) * (1 + cos(xi) * alpha / (PI / 2.0d0))
-
- surfx = RICB_KM * cos(3 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
- surfy = RICB_KM * sin(3 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
-
- dist_cc_icb = sqrt((surfx -x)**2 + (surfy - y)**2)
- if(ix /= nex_xi/2) then
- dist_cc_icb = dist_cc_icb * 2
- endif
- somme = somme + dist_cc_icb
- end do
- dist_moy = somme / (nex_xi + 1)
- ner = nint(dist_moy / ((PI * RICB_KM) / (2*nex_xi)))
- end subroutine compute_nex
-
- subroutine get_element(points, ispec, npts, pts)
- implicit none
- integer npts, ispec
- integer, parameter :: NBNODE = 8
- double precision pts(NBNODE+1,2), points(npts,2)
- pts(1:8,:) = points( ( (ispec-1) * NBNODE)+1 : ( (ispec) * NBNODE )+1, : )
- pts(NBNODE+1,:) = pts(1,:) ! Use first point as the last point
- end subroutine get_element
-
- subroutine get_size_min_max(pts, edgemax, edgemin)
- implicit none
- integer ie, ix1,ix2,ix3
- integer, parameter :: NBNODE = 8
- double precision edgemax, edgemin, edge
- double precision pts(NBNODE+1, 2)
-
-
- edgemax = -1e7
- edgemin = -edgemax
- do ie = 1,NBNODE/2,1
- ix1 = (ie * 2) - 1
- ix2 = ix1 + 1
- ix3 = ix1 + 2
- edge = sqrt( (pts(ix1,1) - pts(ix2,1))**2 + (pts(ix1,2) - pts(ix2,2))**2 ) + &
- sqrt( (pts(ix2,1) - pts(ix3,1))**2 + (pts(ix2,2) - pts(ix3,2))**2 )
- edgemax = MAX(edgemax, edge)
- edgemin = MIN(edgemin, edge)
- end do
- end subroutine get_size_min_max
-
- subroutine compute_IC_mesh(rcube, points, npts, nspec_cube, nspec_chunks, nex_xi, nex_eta)
- implicit none
-
- integer, parameter :: NBNODE = 8
- integer npts
- integer nspec_chunks, nspec_cube
-
- double precision rcube
- double precision alpha
- double precision points(npts, 2)
- double precision x, y
-
- integer nex_eta, nex_xi
- integer ic, ix, iy, in
- integer, parameter, dimension(NBNODE) :: iaddx(NBNODE) = (/0,1,2,2,2,1,0,0/)
- integer, parameter, dimension(NBNODE) :: iaddy(NBNODE) = (/0,0,0,1,2,2,2,1/)
- integer k
-
- k = 1
- alpha = 0.41d0
- nspec_chunks = 0
- do ic = 0,3
- do ix = 0,(nex_xi-1)*2,2
- do iy = 0,(nex_eta-1)*2,2
- do in = 1,NBNODE
- call compute_coordinate(ix+iaddx(in), iy+iaddy(in), nex_xi*2, nex_eta*2, rcube, ic, alpha, x,y)
- points(k,1) = x
- points(k,2) = y
- k = k + 1
- end do
- nspec_chunks = nspec_chunks + 1
- end do
- end do
- end do
-
- nspec_cube = 0
- do ix = 0,(nex_xi-1)*2,2
- do iy = 0,(nex_xi-1)*2,2
- do in = 1,NBNODE
- call compute_coordinate_central_cube(ix+iaddx(in), iy+iaddy(in), nex_xi*2, nex_xi*2, rcube, alpha,x,y)
- points(k,1) = x
- points(k,2) = y
- k = k + 1
- end do
- nspec_cube = nspec_cube + 1
- end do
- end do
-
- end subroutine compute_IC_mesh
-
- subroutine compute_coordinate_central_cube(ix,iy,nbx,nby,radius, alpha, x, y)
- implicit none
-
- double precision, parameter :: PI = 3.1415d0
-
- integer ix, iy, nbx, nby
- double precision radius, alpha
- double precision x, y
-
- double precision ratio_x, ratio_y
- double precision factx, facty
- double precision xi, eta
-
- ratio_x = (ix * 1.0d0) / (nbx * 1.0d0)
- ratio_y = (iy * 1.0d0) / (nby * 1.0d0)
-
- factx = 2.0d0 * ratio_x - 1.0d0
- facty = 2.0d0 * ratio_y - 1.0d0
-
- xi = (PI / 2.0d0) * factx
- eta = (PI / 2.0d0) * facty
-
- x = (radius / sqrt(2.0d0)) * factx * ( 1 + cos(eta) * alpha / (PI / 2.0d0))
- y = (radius / sqrt(2.0d0)) * facty * ( 1 + cos(xi) * alpha / (PI / 2.0d0))
-
- end subroutine compute_coordinate_central_cube
-
- subroutine compute_coordinate(ix,iy,nbx, nby, rcube, ic, alpha, x, y)
- implicit none
-
- double precision, parameter :: PI = 3.1415d0
- double precision, parameter :: RICB_KM = 1221.0d0
-
- integer ix, iy, nbx, nby, ic
- double precision rcube, alpha
- double precision x, y
-
- double precision ratio_x, ratio_y
- double precision factx, xi
- double precision xcc, ycc
- double precision xsurf, ysurf
- double precision deltax, deltay
- double precision temp
-
- ratio_x = (ix * 1.0d0) / (nbx * 1.0d0)
- ratio_y = (iy * 1.0d0) / (nby * 1.0d0)
-
- factx = 2.0d0 * ratio_x - 1.0d0
- xi = (PI/2.0d0) * factx
-
- xcc = (rcube / sqrt(2.0d0)) * factx
- ycc = (rcube / sqrt(2.0d0)) * (1 + cos(xi) * alpha / (PI/2.0d0))
-
- xsurf = RICB_KM * cos(3.0d0 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
- ysurf = RICB_KM * sin(3.0d0 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
-
- deltax = xsurf - xcc
- deltay = ysurf - ycc
-
- x = xsurf - ratio_y * deltax
- y = ysurf - ratio_y * deltay
-
- if(ic == 1) then
- temp = x
- x = y
- y = temp
- else if (ic == 2) then
- x = -x
- y = -y
- else if (ic == 3) then
- temp = x
- x = -y
- y = temp
- end if
- end subroutine compute_coordinate
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/calc_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/calc_jacobian.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/calc_jacobian.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,145 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 calc_jacobian(myrank,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- xstore,ystore,zstore, &
- xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer ispec,nspec,myrank
-
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
- double precision dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
-!! 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
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer i,j,k,ia
-
- double precision xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
- double precision xmesh,ymesh,zmesh
- double precision xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- double precision jacobian
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- xxi = ZERO
- xeta = ZERO
- xgamma = ZERO
- yxi = ZERO
- yeta = ZERO
- ygamma = ZERO
- zxi = ZERO
- zeta = ZERO
- zgamma = ZERO
- xmesh = ZERO
- ymesh = ZERO
- zmesh = ZERO
-
- do ia=1,NGNOD
- xxi = xxi + dershape3D(1,ia,i,j,k)*xelm(ia)
- xeta = xeta + dershape3D(2,ia,i,j,k)*xelm(ia)
- xgamma = xgamma + dershape3D(3,ia,i,j,k)*xelm(ia)
- yxi = yxi + dershape3D(1,ia,i,j,k)*yelm(ia)
- yeta = yeta + dershape3D(2,ia,i,j,k)*yelm(ia)
- ygamma = ygamma + dershape3D(3,ia,i,j,k)*yelm(ia)
- zxi = zxi + dershape3D(1,ia,i,j,k)*zelm(ia)
- zeta = zeta + dershape3D(2,ia,i,j,k)*zelm(ia)
- zgamma = zgamma + dershape3D(3,ia,i,j,k)*zelm(ia)
- xmesh = xmesh + shape3D(ia,i,j,k)*xelm(ia)
- ymesh = ymesh + shape3D(ia,i,j,k)*yelm(ia)
- zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
- enddo
-
- jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
- xeta*(yxi*zgamma-ygamma*zxi) + &
- xgamma*(yxi*zeta-yeta*zxi)
-
- if(jacobian <= ZERO) call exit_MPI(myrank,'3D Jacobian undefined')
-
-! invert the relation (Fletcher p. 50 vol. 2)
- xix = (yeta*zgamma-ygamma*zeta) / jacobian
- xiy = (xgamma*zeta-xeta*zgamma) / jacobian
- xiz = (xeta*ygamma-xgamma*yeta) / jacobian
- etax = (ygamma*zxi-yxi*zgamma) / jacobian
- etay = (xxi*zgamma-xgamma*zxi) / jacobian
- etaz = (xgamma*yxi-xxi*ygamma) / jacobian
- gammax = (yxi*zeta-yeta*zxi) / jacobian
- gammay = (xeta*zxi-xxi*zeta) / jacobian
- gammaz = (xxi*yeta-xeta*yxi) / jacobian
-
-! save the derivatives and the jacobian
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- xixstore(i,j,k) = sngl(xix)
- xiystore(i,j,k) = sngl(xiy)
- xizstore(i,j,k) = sngl(xiz)
- etaxstore(i,j,k) = sngl(etax)
- etaystore(i,j,k) = sngl(etay)
- etazstore(i,j,k) = sngl(etaz)
- gammaxstore(i,j,k) = sngl(gammax)
- gammaystore(i,j,k) = sngl(gammay)
- gammazstore(i,j,k) = sngl(gammaz)
- else
- xixstore(i,j,k) = xix
- xiystore(i,j,k) = xiy
- xizstore(i,j,k) = xiz
- etaxstore(i,j,k) = etax
- etaystore(i,j,k) = etay
- etazstore(i,j,k) = etaz
- gammaxstore(i,j,k) = gammax
- gammaystore(i,j,k) = gammay
- gammazstore(i,j,k) = gammaz
- endif
-
-! store mesh coordinates
- xstore(i,j,k,ispec) = xmesh
- ystore(i,j,k,ispec) = ymesh
- zstore(i,j,k,ispec) = zmesh
-
- enddo
- enddo
- enddo
-
- end subroutine calc_jacobian
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call1.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call1.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call1.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,45 +0,0 @@
-
-!! DK DK created this for merged version
-
- call specfem3D( &
-!! DK DK to do later, for attenuation only; not done yet by lack of time
- omsb_crust_mantle_dble,factor_scale_crust_mantle_dble, omsb_inner_core_dble,factor_scale_inner_core_dble, &
- one_minus_sum_beta_crust_mantle,factor_scale_crust_mantle, one_minus_sum_beta_inner_core,factor_scale_inner_core, &
- factor_common_crust_mantle,factor_common_inner_core,factor_common_crust_mantle_dble, factor_common_inner_core_dble, &
-!! DK DK to do later, for oceans only
- rmass_ocean_load, &
-!! DK DK already computed
- myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo, &
- 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, &
-!! DK DK recomputed after the end of the mesher and before the beginning of the solver
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,xstore_outer_core,ystore_outer_core,zstore_outer_core, &
-xstore_inner_core,ystore_inner_core,zstore_inner_core, &
-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, &
-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, &
- 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, &
-!! DK DK do not need to be initialized
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
- displ_outer_core,veloc_outer_core,accel_outer_core,displ_inner_core,veloc_inner_core,accel_inner_core, &
- buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
- buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
-R_memory_crust_mantle, epsilondev_crust_mantle, R_memory_inner_core, epsilondev_inner_core)
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call2.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call2.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call2.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,45 +0,0 @@
-
-!! DK DK created this for merged version
-
- subroutine specfem3D( &
-!! DK DK to do later, for attenuation only; not done yet by lack of time
- omsb_crust_mantle_dble,factor_scale_crust_mantle_dble, omsb_inner_core_dble,factor_scale_inner_core_dble, &
- one_minus_sum_beta_crust_mantle,factor_scale_crust_mantle, one_minus_sum_beta_inner_core,factor_scale_inner_core, &
- factor_common_crust_mantle,factor_common_inner_core,factor_common_crust_mantle_dble, factor_common_inner_core_dble, &
-!! DK DK to do later, for oceans only
- rmass_ocean_load, &
-!! DK DK already computed
- myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo, &
- 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, &
-!! DK DK recomputed after the end of the mesher and before the beginning of the solver
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,xstore_outer_core,ystore_outer_core,zstore_outer_core, &
-xstore_inner_core,ystore_inner_core,zstore_inner_core, &
-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, &
-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, &
- 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, &
-!! DK DK do not need to be initialized
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
- displ_outer_core,veloc_outer_core,accel_outer_core,displ_inner_core,veloc_inner_core,accel_inner_core, &
- buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
- buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
-R_memory_crust_mantle, epsilondev_crust_mantle, R_memory_inner_core, epsilondev_inner_core)
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_mass_matrix_one_element.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_mass_matrix_one_element.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_mass_matrix_one_element.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,80 +0,0 @@
-
-!! DK DK added this for merged version
-
- if(ipass == 2) then
-
-! suppress fictitious elements in central cube
-! also take into account the fact that array idoubling is not allocated for the outer core
- add_contrib_this_element = .true.
- if(iregion_code == IREGION_INNER_CORE) then
- if(idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) add_contrib_this_element = .false.
- endif
-
- if(add_contrib_this_element) then
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- weight = wxgll(i)*wygll(j)*wzgll(k)
-
-!! DK DK changed this for merged version
-! if(PERFORM_CUTHILL_MCKEE) then
-! iglobnum = ibool(i,j,k,invperm(ispec))
-! iglobnum = ibool(i,j,k,perm(ispec))
-! else
- iglobnum = ibool(i,j,k,ispec)
-! endif
-
-! compute the jacobian
- 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))
-
-! definition depends if region is fluid or solid
- if(iregion_code == IREGION_CRUST_MANTLE .or. iregion_code == IREGION_INNER_CORE) then
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglobnum) = rmass(iglobnum) + &
- sngl(dble(rhostore_local(i,j,k)) * dble(jacobianl) * weight)
- else
- rmass(iglobnum) = rmass(iglobnum) + rhostore_local(i,j,k) * jacobianl * weight
- endif
-
-! fluid in outer core
- else if(iregion_code == IREGION_OUTER_CORE) then
-
-! no anisotropy in the fluid, use kappav
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglobnum) = rmass(iglobnum) + &
- sngl(dble(jacobianl) * weight * dble(rhostore_local(i,j,k)) / dble(kappavstore_local(i,j,k)))
- else
- rmass(iglobnum) = rmass(iglobnum) + &
- jacobianl * weight * rhostore_local(i,j,k) / kappavstore_local(i,j,k)
- endif
-
- else
- call exit_MPI(myrank,'wrong region code')
- endif
-
- enddo
- enddo
- enddo
-
- endif ! of exclusion of fictitious inner core elements
-
- endif ! of ipass == 2
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_spectrum.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_spectrum.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_spectrum.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,39 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
- double precision function comp_source_spectrum(om,hdur)
-
- implicit none
-
- include "constants.h"
-
- double precision om,hdur
-
- comp_source_spectrum = dexp(-0.25d0*(om*hdur/SOURCE_DECAY_MIMIC_TRIANGLE)**2)
-
- end function comp_source_spectrum
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_time_function.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_time_function.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_time_function.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,42 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
- double precision function comp_source_time_function(t,hdur)
-
- implicit none
-
- include "constants.h"
-
- double precision t,hdur
-
- double precision, external :: netlib_specfun_erf
-
-! quasi Heaviside
- comp_source_time_function = 0.5d0*(1.0d0 + netlib_specfun_erf(t/hdur))
-
- end function comp_source_time_function
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_arrays_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_arrays_source.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_arrays_source.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,331 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 compute_arrays_source(ispec_selected_source, &
- xi_source,eta_source,gamma_source,sourcearray, &
- Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- xigll,yigll,zigll,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer ispec_selected_source,nspec
-
- double precision xi_source,eta_source,gamma_source
- double precision Mxx,Myy,Mzz,Mxy,Mxz,Myz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xix,xiy,xiz,etax,etay,etaz, &
- gammax,gammay,gammaz
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
-
- double precision xixd,xiyd,xizd,etaxd,etayd,etazd,gammaxd,gammayd,gammazd
-
-! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLY) :: yigll
- double precision, dimension(NGLLZ) :: zigll
-
-! source arrays
- double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: G11,G12,G13,G21,G22,G23,G31,G32,G33
- double precision, dimension(NGLLX) :: hxis,hpxis
- double precision, dimension(NGLLY) :: hetas,hpetas
- double precision, dimension(NGLLZ) :: hgammas,hpgammas
-
- integer k,l,m
-
-! calculate G_ij for general source location
-! the source does not necessarily correspond to a Gauss-Lobatto point
- do m=1,NGLLZ
- do l=1,NGLLY
- do k=1,NGLLX
-
- xixd = dble(xix(k,l,m,ispec_selected_source))
- xiyd = dble(xiy(k,l,m,ispec_selected_source))
- xizd = dble(xiz(k,l,m,ispec_selected_source))
- etaxd = dble(etax(k,l,m,ispec_selected_source))
- etayd = dble(etay(k,l,m,ispec_selected_source))
- etazd = dble(etaz(k,l,m,ispec_selected_source))
- gammaxd = dble(gammax(k,l,m,ispec_selected_source))
- gammayd = dble(gammay(k,l,m,ispec_selected_source))
- gammazd = dble(gammaz(k,l,m,ispec_selected_source))
-
- G11(k,l,m) = Mxx*xixd+Mxy*xiyd+Mxz*xizd
- G12(k,l,m) = Mxx*etaxd+Mxy*etayd+Mxz*etazd
- G13(k,l,m) = Mxx*gammaxd+Mxy*gammayd+Mxz*gammazd
- G21(k,l,m) = Mxy*xixd+Myy*xiyd+Myz*xizd
- G22(k,l,m) = Mxy*etaxd+Myy*etayd+Myz*etazd
- G23(k,l,m) = Mxy*gammaxd+Myy*gammayd+Myz*gammazd
- G31(k,l,m) = Mxz*xixd+Myz*xiyd+Mzz*xizd
- G32(k,l,m) = Mxz*etaxd+Myz*etayd+Mzz*etazd
- G33(k,l,m) = Mxz*gammaxd+Myz*gammayd+Mzz*gammazd
-
- enddo
- enddo
- enddo
-
-! compute Lagrange polynomials at the source location
- call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
- call lagrange_any(eta_source,NGLLY,yigll,hetas,hpetas)
- call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
-
-! calculate source array
- do m=1,NGLLZ
- do l=1,NGLLY
- do k=1,NGLLX
- call multiply_arrays_source(sourcearrayd,G11,G12,G13,G21,G22,G23, &
- G31,G32,G33,hxis,hpxis,hetas,hpetas,hgammas,hpgammas,k,l,m)
- enddo
- enddo
- enddo
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- sourcearray(:,:,:,:) = sngl(sourcearrayd(:,:,:,:))
- else
- sourcearray(:,:,:,:) = sourcearrayd(:,:,:,:)
- endif
-
- end subroutine compute_arrays_source
-
-!================================================================
-
-! we put these multiplications in a separate routine because otherwise
-! some compilers try to unroll the six loops above and take forever to compile
- subroutine multiply_arrays_source(sourcearrayd,G11,G12,G13,G21,G22,G23, &
- G31,G32,G33,hxis,hpxis,hetas,hpetas,hgammas,hpgammas,k,l,m)
-
- implicit none
-
- include "constants.h"
-
-! source arrays
- double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: G11,G12,G13,G21,G22,G23,G31,G32,G33
- double precision, dimension(NGLLX) :: hxis,hpxis
- double precision, dimension(NGLLY) :: hetas,hpetas
- double precision, dimension(NGLLZ) :: hgammas,hpgammas
-
- integer k,l,m
-
- integer ir,it,iv
-
- sourcearrayd(:,k,l,m) = ZERO
-
- do iv=1,NGLLZ
- do it=1,NGLLY
- do ir=1,NGLLX
-
- sourcearrayd(1,k,l,m) = sourcearrayd(1,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
- *(G11(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
- +G12(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
- +G13(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
-
- sourcearrayd(2,k,l,m) = sourcearrayd(2,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
- *(G21(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
- +G22(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
- +G23(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
-
- sourcearrayd(3,k,l,m) = sourcearrayd(3,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
- *(G31(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
- +G32(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
- +G33(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
-
- enddo
- enddo
- enddo
-
- end subroutine multiply_arrays_source
-
-!================================================================
-
-subroutine compute_arrays_adjoint_source(myrank, adj_source_file, &
- xi_receiver,eta_receiver,gamma_receiver, nu,adj_sourcearray, &
- xigll,yigll,zigll,NSTEP)
-
- implicit none
-
- include 'constants.h'
-
-! input
- integer myrank, NSTEP
-
- double precision xi_receiver, eta_receiver, gamma_receiver
-
- character(len=*) adj_source_file
-
-! output
- real(kind=CUSTOM_REAL) :: adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ)
-
-! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLY) :: yigll
- double precision, dimension(NGLLZ) :: zigll
-
- double precision, dimension(NDIM,NDIM) :: nu
-
- double precision scale_displ
-
- double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
- hgammar(NGLLZ), hpgammar(NGLLZ)
- real(kind=CUSTOM_REAL) :: adj_src(NSTEP,NDIM),adj_src_u(NSTEP,NDIM)
-
- integer icomp, itime, i, j, k, ios
- double precision :: junk
- character(len=3) :: comp(NDIM)
- character(len=150) :: filename
-
- scale_displ = R_EARTH
-
- call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
- call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
- call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
-
- adj_sourcearray(:,:,:,:,:) = 0.
-
- comp = (/"LHN", "LHE", "LHZ"/)
-
- do icomp = 1, NDIM
-
- filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
- open(unit = IIN, file = trim(filename), iostat = ios)
- if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//' does not exist')
- do itime = 1, NSTEP
- read(IIN,*) junk, adj_src(itime,icomp)
- enddo
- close(IIN)
-
- enddo
-
- adj_src = adj_src/scale_displ
-
- do itime = 1, NSTEP
- adj_src_u(itime,:) = nu(1,:) * adj_src(itime,1) + nu(2,:) * adj_src(itime,2) + nu(3,:) * adj_src(itime,3)
- enddo
-
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- adj_sourcearray(:,:,i,j,k) = hxir(i) * hetar(j) * hgammar(k) * adj_src_u(:,:)
- enddo
- enddo
- enddo
-
-
-end subroutine compute_arrays_adjoint_source
-
-!================================================================
-
-subroutine comp_subarrays_adjoint_src(myrank, adj_source_file, &
- xi_receiver,eta_receiver,gamma_receiver, nu,adj_sourcearray, &
- xigll,yigll,zigll,NSTEP,iadjsrc,it_sub_adj,NSTEP_SUB_ADJ, &
- NTSTEP_BETWEEN_READ_ADJSRC)
-
- implicit none
-
- include 'constants.h'
-
-! input -- notice here NSTEP is different from the NSTEP in the main program
-! instead NSTEP = iadjsrc_len(it_sub_adj), the length of this specific block
- integer myrank, NSTEP
-
- double precision xi_receiver, eta_receiver, gamma_receiver
-
- character(len=*) adj_source_file
-
-! Vala added
- integer it_sub_adj,NSTEP_SUB_ADJ,NTSTEP_BETWEEN_READ_ADJSRC
- integer, dimension(NSTEP_SUB_ADJ,2) :: iadjsrc
-
-! output
- real(kind=CUSTOM_REAL) :: adj_sourcearray(NTSTEP_BETWEEN_READ_ADJSRC,NDIM,NGLLX,NGLLY,NGLLZ)
-
-! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLY) :: yigll
- double precision, dimension(NGLLZ) :: zigll
-
- double precision, dimension(NDIM,NDIM) :: nu
-
- double precision scale_displ
-
- double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
- hgammar(NGLLZ), hpgammar(NGLLZ)
- real(kind=CUSTOM_REAL) :: adj_src(NSTEP,NDIM),adj_src_u(NSTEP,NDIM)
-
- integer icomp, itime, i, j, k, ios
- double precision :: junk
- character(len=3) :: comp(NDIM)
- character(len=150) :: filename
-
- scale_displ = R_EARTH
-
- call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
- call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
- call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
-
- adj_sourcearray(:,:,:,:,:) = 0.
-
- comp = (/"LHN", "LHE", "LHZ"/)
-
- do icomp = 1, NDIM
-
- filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
- open(unit = IIN, file = trim(filename), iostat = ios)
- if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//'does not exist')
- do itime =1,iadjsrc(it_sub_adj,1)-1
- read(IIN,*) junk,junk
- enddo
- do itime = iadjsrc(it_sub_adj,1), iadjsrc(it_sub_adj,1)+NSTEP-1
- read(IIN,*) junk, adj_src(itime-iadjsrc(it_sub_adj,1)+1,icomp)
- enddo
- close(IIN)
-
- enddo
-
- adj_src = adj_src/scale_displ
-
- do itime = 1, NSTEP
- adj_src_u(itime,:) = nu(1,:) * adj_src(itime,1) + nu(2,:) * adj_src(itime,2) + nu(3,:) * adj_src(itime,3)
- enddo
-
-
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- adj_sourcearray(1:NSTEP,:,i,j,k) = hxir(i) * hetar(j) * hgammar(k) * adj_src_u(:,:)
- enddo
- enddo
- enddo
-
-
-end subroutine comp_subarrays_adjoint_src
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_coordinates_grid.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_coordinates_grid.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_coordinates_grid.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,327 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 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,r_bottom,ner,ilayer,ichunk,rotation_matrix,NCHUNKS,&
- INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
-
- implicit none
-
- include "constants.h"
-
- double precision, dimension(NGNOD) :: xelm,yelm,zelm,offset_x,offset_y,offset_z
-
-! rotation matrix from Euler angles
- double precision, dimension(NDIM,NDIM) :: rotation_matrix
-
- integer, intent(in) :: iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA, &
- NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ner,ilayer,ichunk,NCHUNKS
-
- double precision :: ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,r_top,r_bottom
-
- logical :: INCLUDE_CENTRAL_CUBE
- integer :: NUMBER_OF_MESH_LAYERS
-
-! local variables
- integer :: i,j,ignod
-
- double precision :: xi,eta,gamma,x,y,x_,y_,z,rgb,rgt,rn
- double precision :: x_bot,y_bot,z_bot
- double precision :: x_top,y_top,z_top
-
- double precision, dimension(NDIM) :: vector_ori,vector_rotated
-
- double precision :: ratio_xi, ratio_eta, fact_xi, fact_eta, &
- fact_xi_,fact_eta_
-
- double precision, parameter :: PI_OVER_TWO = PI / 2.d0
-
-
-! this to avoid compilation warnings
- x_=0
- y_=0
-
-! loop on all the nodes in this element
- do ignod = 1,NGNOD
-
- if(ilayer == NUMBER_OF_MESH_LAYERS .and. INCLUDE_CENTRAL_CUBE) then
-! case of the inner core
- ratio_xi = ((iproc_xi + offset_x(ignod)/dble(NEX_PER_PROC_XI))/dble(NPROC_XI))
- fact_xi = 2.d0*ratio_xi-1.d0
-
- ratio_eta = ((iproc_eta + offset_y(ignod)/dble(NEX_PER_PROC_ETA))/dble(NPROC_ETA))
- fact_eta = 2.d0*ratio_eta-1.d0
-
- fact_xi_ = tan((ANGULAR_WIDTH_XI_RAD/2.d0) * fact_xi)
- fact_eta_ = tan((ANGULAR_WIDTH_ETA_RAD/2.d0) * fact_eta)
-
-! uncomment the following lines to have more regular surface mesh (better aspect ratio for each element)
-! uncomment the corresponding lines in the else condition of this if statement too.
-! note that the ratio bigger_edge_size/smaller_edge_size for the surface mesh is a bit higher (1.43 vs 1.41)
-
-! fact_xi_= (3.d0*fact_xi+4.d0*fact_xi_)/7.d0
-! fact_eta_= (3.d0*fact_eta+4.d0*fact_eta_)/7.d0
-
- xi = PI_OVER_TWO*fact_xi
- eta = PI_OVER_TWO*fact_eta
-
- gamma = ONE / sqrt(ONE + fact_xi_**2 + fact_eta_**2)
- rgt = (r_top / R_EARTH)*gamma
-
-! coordinates of the edge extremity on the central cube surface
- x_bot = ((r_bottom / R_EARTH) / sqrt(3.d0))* fact_xi * (1 + cos(eta)*CENTRAL_CUBE_INFLATE_FACTOR / PI)
- y_bot = ((r_bottom / R_EARTH) / sqrt(3.d0)) * fact_eta * (1 + cos(xi)*CENTRAL_CUBE_INFLATE_FACTOR / PI)
- z_bot = ((r_bottom / R_EARTH) / sqrt(3.d0)) * (1 + (cos(xi) + cos(eta))*CENTRAL_CUBE_INFLATE_FACTOR / PI)
-
-! coordinates of the edge extremity on the ICB
- x_top = fact_xi_*rgt
- y_top = fact_eta_*rgt
- z_top = rgt
-
- rn = offset_z(ignod) / dble(ner)
- x = x_top*rn + x_bot*(ONE-rn)
- y = y_top*rn + y_bot*(ONE-rn)
- z = z_top*rn + z_bot*(ONE-rn)
-
- select case (ichunk)
- case(CHUNK_AB)
- xelm(ignod) = -y
- yelm(ignod) = x
- zelm(ignod) = z
- case(CHUNK_AB_ANTIPODE)
- xelm(ignod) = -y
- yelm(ignod) = -x
- zelm(ignod) = -z
- case(CHUNK_AC)
- xelm(ignod) = -y
- yelm(ignod) = -z
- zelm(ignod) = x
- case(CHUNK_AC_ANTIPODE)
- xelm(ignod) = -y
- yelm(ignod) = z
- zelm(ignod) = -x
- case(CHUNK_BC)
- xelm(ignod) = -z
- yelm(ignod) = y
- zelm(ignod) = x
- case(CHUNK_BC_ANTIPODE)
- xelm(ignod) = z
- yelm(ignod) = -y
- zelm(ignod) = x
- case default
- stop 'incorrect chunk number in compute_coord_main_mesh'
- end select
-! write(IMAIN,*) x,' ',y,' ',z
- else
-
-! uncomment the following lines to have more regular surface mesh (better aspect ratio for each element)
-! note that the ratio bigger_edge_size/smaller_edge_size for the surface mesh is a bit higher (1.43 vs 1.41)
-! ratio_xi = ((iproc_xi + offset_x(ignod)/dble(NEX_PER_PROC_XI))/dble(NPROC_XI))*tan(ANGULAR_WIDTH_XI_RAD/2.d0)
-! x_ = 2.d0*ratio_xi-tan(ANGULAR_WIDTH_XI_RAD/2.d0)
-! ratio_eta = ((iproc_eta + offset_y(ignod)/dble(NEX_PER_PROC_ETA))/dble(NPROC_ETA))*tan(ANGULAR_WIDTH_ETA_RAD/2.d0)
-! y_ = 2.d0*ratio_eta-tan(ANGULAR_WIDTH_ETA_RAD/2.d0)
-
- ratio_xi = ((iproc_xi + offset_x(ignod)/dble(NEX_PER_PROC_XI))/dble(NPROC_XI))
- x = 2.d0*ratio_xi-1
-
- ratio_eta = ((iproc_eta + offset_y(ignod)/dble(NEX_PER_PROC_ETA))/dble(NPROC_ETA))
- y = 2.d0*ratio_eta-1
-
- x = tan((ANGULAR_WIDTH_XI_RAD/2.d0) * x)
- y = tan((ANGULAR_WIDTH_ETA_RAD/2.d0) * y)
-
-! uncomment the following lines to have more regular surface mesh (better aspect ratio for each element)
-! note that the ratio bigger_edge_size/smaller_edge_size for the surface mesh is a bit higher (1.43 vs 1.41)
-! x= (3.d0*x_+4.d0*x)/7.d0
-! y= (3.d0*y_+4.d0*y)/7.d0
-
- gamma = ONE / sqrt(ONE + x*x + y*y)
-
- rgt = (r_top / R_EARTH)*gamma
- rgb = (r_bottom / R_EARTH)*gamma
-
- ! define the mesh points on the top and the bottom in the six regions of the cubed shpere
- select case (ichunk)
-
- case(CHUNK_AB)
-
- x_top = -y*rgt
- y_top = x*rgt
- z_top = rgt
-
- x_bot = -y*rgb
- y_bot = x*rgb
- z_bot = rgb
-
- case(CHUNK_AB_ANTIPODE)
-
- x_top = -y*rgt
- y_top = -x*rgt
- z_top = -rgt
-
- x_bot = -y*rgb
- y_bot = -x*rgb
- z_bot = -rgb
-
- case(CHUNK_AC)
-
- x_top = -y*rgt
- y_top = -rgt
- z_top = x*rgt
-
- x_bot = -y*rgb
- y_bot = -rgb
- z_bot = x*rgb
-
- case(CHUNK_AC_ANTIPODE)
-
- x_top = -y*rgt
- y_top = rgt
- z_top = -x*rgt
-
- x_bot = -y*rgb
- y_bot = rgb
- z_bot = -x*rgb
-
- case(CHUNK_BC)
-
- x_top = -rgt
- y_top = y*rgt
- z_top = x*rgt
-
- x_bot = -rgb
- y_bot = y*rgb
- z_bot = x*rgb
-
- case(CHUNK_BC_ANTIPODE)
-
- x_top = rgt
- y_top = -y*rgt
- z_top = x*rgt
-
- x_bot = rgb
- y_bot = -y*rgb
- z_bot = x*rgb
-
- case default
- stop 'incorrect chunk number in compute_coord_main_mesh'
-
- end select
-
- ! rotate the chunk to the right location if we do not mesh the full Earth
- if(NCHUNKS /= 6) then
-
- ! rotate bottom
- vector_ori(1) = x_bot
- vector_ori(2) = y_bot
- vector_ori(3) = z_bot
- do i = 1,NDIM
- vector_rotated(i) = ZERO
- do j = 1,NDIM
- vector_rotated(i) = vector_rotated(i) + rotation_matrix(i,j)*vector_ori(j)
- enddo
- enddo
- x_bot = vector_rotated(1)
- y_bot = vector_rotated(2)
- z_bot = vector_rotated(3)
-
- ! rotate top
- vector_ori(1) = x_top
- vector_ori(2) = y_top
- vector_ori(3) = z_top
- do i = 1,NDIM
- vector_rotated(i) = ZERO
- do j = 1,NDIM
- vector_rotated(i) = vector_rotated(i) + rotation_matrix(i,j)*vector_ori(j)
- enddo
- enddo
- x_top = vector_rotated(1)
- y_top = vector_rotated(2)
- z_top = vector_rotated(3)
-
- endif
-
- ! compute the position of the point
- rn = offset_z(ignod) / dble(ner)
- xelm(ignod) = x_top*rn + x_bot*(ONE-rn)
- yelm(ignod) = y_top*rn + y_bot*(ONE-rn)
- zelm(ignod) = z_top*rn + z_bot*(ONE-rn)
-
- endif
- enddo
-! if(ilayer == NUMBER_OF_MESH_LAYERS .and. INCLUDE_CENTRAL_CUBE) write(IMAIN,*)
- end subroutine compute_coord_main_mesh
-
-!---------------------------------------------------------------------------
-
-!! DK DK create value of arrays xgrid ygrid and zgrid in the central cube without storing them
-
- subroutine compute_coord_central_cube(ix,iy,iz, &
- 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)
-
- implicit none
-
- include "constants.h"
-
- integer :: ix,iy,iz,iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,nx_central_cube,ny_central_cube,nz_central_cube
-
- double precision :: xgrid_central_cube,ygrid_central_cube,zgrid_central_cube,radius_cube
-
-! local variables
- double precision :: ratio_x,ratio_y,ratio_z
- double precision :: fact_x,fact_y,fact_z,xi,eta,gamma
- double precision, parameter :: PI_OVER_TWO = PI / 2.d0
-
-! the slice extends to the entire cube along Z
-! but only to current block along X and Y
- ratio_x = (dble(iproc_xi) + dble(ix)/dble(2*nx_central_cube)) / dble(NPROC_XI)
- ratio_y = (dble(iproc_eta) + dble(iy)/dble(2*ny_central_cube)) / dble(NPROC_ETA)
- ratio_z = dble(iz)/dble(2*nz_central_cube)
-
- if(abs(ratio_x) > 1.001d0 .or. abs(ratio_y) > 1.001d0 .or. abs(ratio_z) > 1.001d0) stop 'wrong ratio in central cube'
-
-! use a "flat" cubed sphere to create the central cube
-
-! map ratio to [-1,1] and then map to real radius
-! then add deformation
- fact_x = 2.d0*ratio_x-1.d0
- fact_y = 2.d0*ratio_y-1.d0
- fact_z = 2.d0*ratio_z-1.d0
-
- xi = PI_OVER_TWO*fact_x;
- eta = PI_OVER_TWO*fact_y;
- gamma = PI_OVER_TWO*fact_z;
-
- xgrid_central_cube = radius_cube * fact_x * (1 + (cos(eta)+cos(gamma))*CENTRAL_CUBE_INFLATE_FACTOR / PI);
- ygrid_central_cube = radius_cube * fact_y * (1 + (cos(xi)+cos(gamma))*CENTRAL_CUBE_INFLATE_FACTOR / PI);
- zgrid_central_cube = radius_cube * fact_z * (1 + (cos(xi)+cos(eta))*CENTRAL_CUBE_INFLATE_FACTOR / PI);
-
- end subroutine compute_coord_central_cube
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_element_properties.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_element_properties.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_element_properties.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,473 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! compute several rheological and geometrical properties for a given spectral element
- subroutine 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)
-
- implicit none
-
- include "constants.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(:), pointer :: 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 ispec,nspec,nspec_stacey
-
- integer REFERENCE_1D_MODEL,THREE_D_MODEL
-
- logical ELLIPTICITY,TOPOGRAPHY
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST
-
- logical ATTENUATION,ATTENUATION_3D,ABSORBING_CONDITIONS
-
- double precision RICB,RCMB,R670,RMOHO, &
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
-
-! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
-! 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)
-
-! code for the four regions of the mesh
- integer iregion_code
-
-! 3D shape functions and their derivatives
- double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
- double precision, dimension(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ) :: dershape3D
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
- double precision, dimension(NGNOD) :: xelm,yelm,zelm
-
-! parameters needed to store the radii of the grid points
-! in the spherically symmetric Earth
- integer idoubling(nspec)
- double precision rmin,rmax
-
-! for model density and anisotropy
- integer nspec_ani
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
-!! DK DK added this for the merged version
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: kappavstore_local
-!! DK DK changed this for merged version
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: rhostore_local
-
-! the 21 coefficients for an anisotropic medium in reduced notation
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store
-
-!! DK DK added this for merged version
- integer :: value_idoubling_to_send
-
-!! 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
-
-! proc numbers for MPI
- integer myrank
-
-! Stacey, indices for Clayton-Engquist absorbing conditions
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
-
-! attenuation
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: Qmu_store
- double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec) :: tau_e_store
- double precision, dimension(N_SLS) :: tau_s
- double precision T_c_source
-
- 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)
-
-! **************
-! add topography on the Moho *before* adding the 3D crustal model so that the streched
-! mesh gets assigned the right model values
-!! DK DK added this for merged version because array idoubling is not allocated in outer core
- if(iregion_code /= IREGION_OUTER_CORE) then
- if(THREE_D_MODEL/=0 .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
- .or. idoubling(ispec)==IFLAG_80_MOHO)) call moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220)
- endif
-
-! compute values for the Earth model
-!! DK DK added this for merged version because array idoubling is not allocated in outer core
- if(iregion_code /= IREGION_OUTER_CORE) then
- value_idoubling_to_send = idoubling(ispec)
- else
- value_idoubling_to_send = IFLAG_OUTER_CORE_NORMAL
- endif
- call get_model(myrank,iregion_code,nspec, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,rhostore_local, &
-!! DK DK added this for the merged version
- kappavstore_local, &
- nspec_ani, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- xelm,yelm,zelm,shape3D,ispec, &
- rmin,rmax,value_idoubling_to_send,rho_vp,rho_vs,nspec_stacey, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
- ATTENUATION, ATTENUATION_3D, tau_s, tau_e_store, Qmu_store, T_c_source, &
- size(tau_e_store,2), size(tau_e_store,3), size(tau_e_store,4), size(tau_e_store,5), &
- ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,&
- 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)
-
-! add topography without the crustal model
-!! DK DK added this for merged version because array idoubling is not allocated in outer core
- if(iregion_code /= IREGION_OUTER_CORE) then
- if(TOPOGRAPHY .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
- .or. idoubling(ispec)==IFLAG_80_MOHO)) call add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
- endif
-
-! add topography on 410 km and 650 km discontinuity in model S362ANI
- if(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) &
- call add_topography_410_650(myrank,xelm,yelm,zelm,R220,R400,R670,R771, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,ylmcof,wk1,wk2,wk3,varstr)
-
-! CMB topography
-!! DK DK merged version: this will not work anymore because idoubling not allocated in outer core
-! if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .and. (idoubling(ispec)==IFLAG_MANTLE_NORMAL &
-! .or. idoubling(ispec)==IFLAG_OUTER_CORE_NORMAL)) &
-! call add_topography_cmb(myrank,xelm,yelm,zelm,RTOPDDOUBLEPRIME,RCMB)
-
-! ICB topography
-!! DK DK merged version: this will not work anymore because idoubling not allocated in outer core
-! if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .and. (idoubling(ispec)==IFLAG_OUTER_CORE_NORMAL &
-! .or. idoubling(ispec)==IFLAG_INNER_CORE_NORMAL .or. 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)) &
-! call add_topography_icb(myrank,xelm,yelm,zelm,RICB,RCMB)
-
-! make the Earth elliptical
- if(ELLIPTICITY) call get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2)
-
-! recompute coordinates and jacobian for real 3-D model
- call calc_jacobian(myrank,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- xstore,ystore,zstore,xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
-
- end subroutine compute_element_properties
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_crust_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_crust_mantle.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_crust_mantle.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,632 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 compute_forces_crust_mantle(displ,accel,xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- ibool,idoubling,R_memory,epsilondev,one_minus_sum_beta, &
- alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec,COMPUTE_AND_STORE_STRAIN, AM_V)
-
- implicit none
-
- include "constants.h"
-
-! include values created by the mesher
-! done for performance only using static allocation to allow for loop unrolling
- include "OUTPUT_FILES/values_from_mesher.h"
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(:), pointer :: 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
-
-! for forward or backward simulations
- logical COMPUTE_AND_STORE_STRAIN
-
-! array with the local to global mapping per slice
- integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling
-
-! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ,accel
-
-! memory variables for attenuation
-! memory variables R_ij are stored at the local rather than global level
-! to allow for optimization of cache access by compiler
- integer i_sls,i_memory
-! variable sized array variables for one_minus_sum_beta and factor_common
- integer vx, vy, vz, vnspec
-
- real(kind=CUSTOM_REAL) one_minus_sum_beta_use,minus_sum_beta
- real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
-
- integer iregion_selected
-
-! for attenuation
- real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev
-
-! [alpha,beta,gamma]val reduced to N_SLS and factor_common to N_SLS*NUM_NODES
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
- real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: factor_common
-
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
-
-! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-
-! 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
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
-
-! x y and z contain r theta and phi
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: xstore,ystore,zstore
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
- kappavstore,muvstore
-
-! store anisotropic properties only where needed to save memory
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
- kappahstore,muhstore,eta_anisostore
-
- integer ispec,iglob
- integer i,j,k,l
-
-! the 21 coefficients for an anisotropic medium in reduced notation
- real(kind=CUSTOM_REAL) c11,c22,c33,c44,c55,c66,c12,c13,c23,c14,c24,c34,c15,c25,c35,c45,c16,c26,c36,c46,c56
-
- real(kind=CUSTOM_REAL) rhovphsq,sinphifour,cosphisq,sinphisq,costhetasq,rhovsvsq,sinthetasq, &
- cosphifour,costhetafour,rhovpvsq,sinthetafour,rhovshsq,cosfourphi, &
- costwotheta,cosfourtheta,sintwophisq,costheta,sinphi,sintheta,cosphi, &
- sintwotheta,costwophi,sintwophi,costwothetasq,costwophisq,phi,theta
-
- real(kind=CUSTOM_REAL) two_rhovpvsq,two_rhovphsq,two_rhovsvsq,two_rhovshsq
- real(kind=CUSTOM_REAL) four_rhovpvsq,four_rhovphsq,four_rhovsvsq,four_rhovshsq
-
- real(kind=CUSTOM_REAL) twoetaminone,etaminone,eta_aniso
- real(kind=CUSTOM_REAL) two_eta_aniso,four_eta_aniso,six_eta_aniso
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
-
- real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
-
- real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
-
- real(kind=CUSTOM_REAL) hp1,hp2,hp3
- real(kind=CUSTOM_REAL) fac1,fac2,fac3
- real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
- real(kind=CUSTOM_REAL) kappal,kappavl,kappahl,muvl,muhl
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
-
- real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
- real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
- real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
-
-! for gravity
- real(kind=CUSTOM_REAL) radius_cr
-
-! ****************************************************
-! big loop over all spectral elements in the solid
-! ****************************************************
-
-! set acceleration to zero
- accel(:,:) = 0._CUSTOM_REAL
-
- do ispec = 1,NSPEC_CRUST_MANTLE
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- tempy1l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
-
- tempz1l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l = tempx1l + displ(1,iglob)*hp1
- tempy1l = tempy1l + displ(2,iglob)*hp1
- tempz1l = tempz1l + displ(3,iglob)*hp1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l = tempx2l + displ(1,iglob)*hp2
- tempy2l = tempy2l + displ(2,iglob)*hp2
- tempz2l = tempz2l + displ(3,iglob)*hp2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l = tempx3l + displ(1,iglob)*hp3
- tempy3l = tempy3l + displ(2,iglob)*hp3
- tempz3l = tempz3l + displ(3,iglob)*hp3
- enddo
-
-! get derivatives of ux, uy and uz with respect to x, y and z
-
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
-
-! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
- duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
- duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
- duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
-
- duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
- duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
- duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
-
-! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
-
-! compute deviatoric strain
- if (COMPUTE_AND_STORE_STRAIN) then
- epsilondev_loc(1,i,j,k) = duxdxl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(2,i,j,k) = duydyl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
- endif
-
-! precompute terms for attenuation if needed
- if(ATTENUATION_VAL) then
- radius_cr = xstore(ibool(i,j,k,ispec))
- call get_attenuation_index(idoubling(ispec), dble(radius_cr), iregion_selected, .FALSE., AM_V)
- one_minus_sum_beta_use = one_minus_sum_beta(1,1,1,iregion_selected)
- minus_sum_beta = one_minus_sum_beta_use - 1.0
- endif
-
-!
-! compute either isotropic or anisotropic elements
-!
-
- if(ANISOTROPIC_3D_MANTLE_VAL) then
-
- else
-
-! do not use transverse isotropy except if element is between d220 and Moho
- if(.not. (TRANSVERSE_ISOTROPY_VAL .and. (idoubling(ispec)==IFLAG_220_80 .or. idoubling(ispec)==IFLAG_80_MOHO))) then
-
-! layer with no transverse isotropy, use kappav and muv
- kappal = kappavstore(i,j,k,ispec)
- mul = muvstore(i,j,k,ispec)
-
-! use unrelaxed parameters if attenuation
- if(ATTENUATION_VAL) mul = mul * one_minus_sum_beta_use
-
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
-
-! compute stress sigma
-
- sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
-
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
-
- else
-
-! use Kappa and mu from transversely isotropic model
- kappavl = kappavstore(i,j,k,ispec)
- muvl = muvstore(i,j,k,ispec)
-
- kappahl = kappahstore(i,j,k,ispec)
- muhl = muhstore(i,j,k,ispec)
-
-! use unrelaxed parameters if attenuation
-! eta does not need to be shifted since it is a ratio
- if(ATTENUATION_VAL) then
- muvl = muvl * one_minus_sum_beta_use
- muhl = muhl * one_minus_sum_beta_use
- endif
-
- rhovpvsq = kappavl + FOUR_THIRDS * muvl !!! that is C
- rhovphsq = kappahl + FOUR_THIRDS * muhl !!! that is A
-
- rhovsvsq = muvl !!! that is L
- rhovshsq = muhl !!! that is N
-
- eta_aniso = eta_anisostore(i,j,k,ispec) !!! that is F / (A - 2 L)
-
-! use mesh coordinates to get theta and phi
-! ystore and zstore contain theta and phi
-
- iglob = ibool(i,j,k,ispec)
- theta = ystore(iglob)
- phi = zstore(iglob)
-
- costheta = cos(theta)
- sintheta = sin(theta)
- cosphi = cos(phi)
- sinphi = sin(phi)
-
- costhetasq = costheta * costheta
- sinthetasq = sintheta * sintheta
- cosphisq = cosphi * cosphi
- sinphisq = sinphi * sinphi
-
- costhetafour = costhetasq * costhetasq
- sinthetafour = sinthetasq * sinthetasq
- cosphifour = cosphisq * cosphisq
- sinphifour = sinphisq * sinphisq
-
- costwotheta = cos(2.*theta)
- sintwotheta = sin(2.*theta)
- costwophi = cos(2.*phi)
- sintwophi = sin(2.*phi)
-
- cosfourtheta = cos(4.*theta)
- cosfourphi = cos(4.*phi)
-
- costwothetasq = costwotheta * costwotheta
-
- costwophisq = costwophi * costwophi
- sintwophisq = sintwophi * sintwophi
-
- etaminone = eta_aniso - 1.
- twoetaminone = 2. * eta_aniso - 1.
-
-! precompute some products to reduce the CPU time
-
- two_eta_aniso = 2.*eta_aniso
- four_eta_aniso = 4.*eta_aniso
- six_eta_aniso = 6.*eta_aniso
-
- two_rhovpvsq = 2.*rhovpvsq
- two_rhovphsq = 2.*rhovphsq
- two_rhovsvsq = 2.*rhovsvsq
- two_rhovshsq = 2.*rhovshsq
-
- four_rhovpvsq = 4.*rhovpvsq
- four_rhovphsq = 4.*rhovphsq
- four_rhovsvsq = 4.*rhovsvsq
- four_rhovshsq = 4.*rhovshsq
-
-! the 21 anisotropic coefficients computed using Mathematica
-
- c11 = rhovphsq*sinphifour + 2.*cosphisq*sinphisq* &
- (rhovphsq*costhetasq + (eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
- sinthetasq) + cosphifour* &
- (rhovphsq*costhetafour + 2.*(eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
- costhetasq*sinthetasq + rhovpvsq*sinthetafour)
-
- c12 = ((rhovphsq - two_rhovshsq)*(3. + cosfourphi)*costhetasq)/4. - &
- four_rhovshsq*cosphisq*costhetasq*sinphisq + &
- (rhovphsq*(11. + 4.*costwotheta + cosfourtheta)*sintwophisq)/32. + &
- eta_aniso*(rhovphsq - two_rhovsvsq)*(cosphifour + &
- 2.*cosphisq*costhetasq*sinphisq + sinphifour)*sinthetasq + &
- rhovpvsq*cosphisq*sinphisq*sinthetafour - &
- rhovsvsq*sintwophisq*sinthetafour
-
- c13 = (cosphisq*(rhovphsq + six_eta_aniso*rhovphsq + rhovpvsq - four_rhovsvsq - &
- 12.*eta_aniso*rhovsvsq + (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - &
- four_eta_aniso*rhovsvsq)*cosfourtheta))/8. + &
- sinphisq*(eta_aniso*(rhovphsq - two_rhovsvsq)*costhetasq + &
- (rhovphsq - two_rhovshsq)*sinthetasq)
-
- c14 = costheta*sinphi*((cosphisq* &
- (-rhovphsq + rhovpvsq + four_rhovshsq - four_rhovsvsq + &
- (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
- four_eta_aniso*rhovsvsq)*costwotheta))/2. + &
- (etaminone*rhovphsq + 2.*(rhovshsq - eta_aniso*rhovsvsq))*sinphisq)* sintheta
-
- c15 = cosphi*costheta*((cosphisq* (-rhovphsq + rhovpvsq + &
- (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
- costwotheta))/2. + etaminone*(rhovphsq - two_rhovsvsq)*sinphisq)*sintheta
-
- c16 = (cosphi*sinphi*(cosphisq* (-rhovphsq + rhovpvsq + &
- (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
- four_eta_aniso*rhovsvsq)*costwotheta) + &
- 2.*etaminone*(rhovphsq - two_rhovsvsq)*sinphisq)*sinthetasq)/2.
-
- c22 = rhovphsq*cosphifour + 2.*cosphisq*sinphisq* &
- (rhovphsq*costhetasq + (eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
- sinthetasq) + sinphifour* &
- (rhovphsq*costhetafour + 2.*(eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
- costhetasq*sinthetasq + rhovpvsq*sinthetafour)
-
- c23 = ((rhovphsq + six_eta_aniso*rhovphsq + rhovpvsq - four_rhovsvsq - 12.*eta_aniso*rhovsvsq + &
- (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
- cosfourtheta)*sinphisq)/8. + &
- cosphisq*(eta_aniso*(rhovphsq - two_rhovsvsq)*costhetasq + &
- (rhovphsq - two_rhovshsq)*sinthetasq)
-
- c24 = costheta*sinphi*(etaminone*(rhovphsq - two_rhovsvsq)*cosphisq + &
- ((-rhovphsq + rhovpvsq + (twoetaminone*rhovphsq - rhovpvsq + &
- four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)*sintheta
-
- c25 = cosphi*costheta*((etaminone*rhovphsq + 2.*(rhovshsq - eta_aniso*rhovsvsq))* &
- cosphisq + ((-rhovphsq + rhovpvsq + four_rhovshsq - four_rhovsvsq + &
- (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
- four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)*sintheta
-
- c26 = (cosphi*sinphi*(2.*etaminone*(rhovphsq - two_rhovsvsq)*cosphisq + &
- (-rhovphsq + rhovpvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
- four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)*sinthetasq)/2.
-
- c33 = rhovpvsq*costhetafour + 2.*(eta_aniso*(rhovphsq - two_rhovsvsq) + two_rhovsvsq)* &
- costhetasq*sinthetasq + rhovphsq*sinthetafour
-
- c34 = -((rhovphsq - rhovpvsq + (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq &
- - four_eta_aniso*rhovsvsq)*costwotheta)*sinphi*sintwotheta)/4.
-
- c35 = -(cosphi*(rhovphsq - rhovpvsq + &
- (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
- costwotheta)*sintwotheta)/4.
-
- c36 = -((rhovphsq - rhovpvsq - four_rhovshsq + four_rhovsvsq + &
- (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
- costwotheta)*sintwophi*sinthetasq)/4.
-
- c44 = cosphisq*(rhovsvsq*costhetasq + rhovshsq*sinthetasq) + &
- sinphisq*(rhovsvsq*costwothetasq + &
- (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + four_eta_aniso*rhovsvsq)*costhetasq* sinthetasq)
-
- c45 = ((rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
- four_eta_aniso*rhovsvsq + (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + &
- 4.*etaminone*rhovsvsq)*costwotheta)*sintwophi*sinthetasq)/4.
-
- c46 = -(cosphi*costheta*((rhovshsq - rhovsvsq)*cosphisq - &
- ((rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
- four_eta_aniso*rhovsvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + &
- four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)* sintheta)
-
- c55 = sinphisq*(rhovsvsq*costhetasq + rhovshsq*sinthetasq) + &
- cosphisq*(rhovsvsq*costwothetasq + &
- (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + four_eta_aniso*rhovsvsq)*costhetasq* sinthetasq)
-
- c56 = costheta*sinphi*((cosphisq* &
- (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
- four_eta_aniso*rhovsvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + &
- four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta))/2. + &
- (-rhovshsq + rhovsvsq)*sinphisq)*sintheta
-
- c66 = rhovshsq*costwophisq*costhetasq - &
- 2.*(rhovphsq - two_rhovshsq)*cosphisq*costhetasq*sinphisq + &
- (rhovphsq*(11. + 4.*costwotheta + cosfourtheta)*sintwophisq)/32. - &
- (rhovsvsq*(-6. - 2.*cosfourphi + cos(4.*phi - 2.*theta) - 2.*costwotheta + &
- cos(2.*(2.*phi + theta)))*sinthetasq)/8. + &
- rhovpvsq*cosphisq*sinphisq*sinthetafour - &
- (eta_aniso*(rhovphsq - two_rhovsvsq)*sintwophisq*sinthetafour)/2.
-
-! general expression of stress tensor for full Cijkl with 21 coefficients
-
- sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
- c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
-
- sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
- c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
-
- sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
- c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
-
- sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
- c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
-
- sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
- c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
-
- sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
- c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
-
- endif
-
- endif ! end of test whether isotropic or anisotropic element
-
-! subtract memory variables if attenuation
- if(ATTENUATION_VAL) then
- do i_sls = 1,N_SLS
- R_xx_val = R_memory(1,i_sls,i,j,k,ispec)
- R_yy_val = R_memory(2,i_sls,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val
- sigma_yy = sigma_yy - R_yy_val
- sigma_zz = sigma_zz + R_xx_val + R_yy_val
- sigma_xy = sigma_xy - R_memory(3,i_sls,i,j,k,ispec)
- sigma_xz = sigma_xz - R_memory(4,i_sls,i,j,k,ispec)
- sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
- enddo
- endif
-
-! form dot product with test vector, symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
-
- enddo
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempy1l = 0._CUSTOM_REAL
- tempz1l = 0._CUSTOM_REAL
-
- tempx2l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
-
- tempx3l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- fac1 = hprimewgll_xx(l,i)
- tempx1l = tempx1l + tempx1(l,j,k)*fac1
- tempy1l = tempy1l + tempy1(l,j,k)*fac1
- tempz1l = tempz1l + tempz1(l,j,k)*fac1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- fac2 = hprimewgll_yy(l,j)
- tempx2l = tempx2l + tempx2(i,l,k)*fac2
- tempy2l = tempy2l + tempy2(i,l,k)*fac2
- tempz2l = tempz2l + tempz2(i,l,k)*fac2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- fac3 = hprimewgll_zz(l,k)
- tempx3l = tempx3l + tempx3(i,j,l)*fac3
- tempy3l = tempy3l + tempy3(i,j,l)*fac3
- tempz3l = tempz3l + tempz3(i,j,l)*fac3
- enddo
-
- fac1 = wgllwgll_yz(j,k)
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
-
- sum_terms(1,i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
- sum_terms(2,i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
- sum_terms(3,i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
-
- enddo
- enddo
- enddo
-
-! sum contributions from each element to the global mesh and add gravity terms
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- accel(1,iglob) = accel(1,iglob) + sum_terms(1,i,j,k)
- accel(2,iglob) = accel(2,iglob) + sum_terms(2,i,j,k)
- accel(3,iglob) = accel(3,iglob) + sum_terms(3,i,j,k)
- enddo
- enddo
- enddo
-
-! update memory variables based upon the Runge-Kutta scheme
-! convention for attenuation
-! term in xx = 1
-! term in yy = 2
-! term in xy = 3
-! term in xz = 4
-! term in yz = 5
-! term in zz not computed since zero trace
-
- if(ATTENUATION_VAL) then
-
-! use Runge-Kutta scheme to march in time
- do i_sls = 1,N_SLS
- do i_memory = 1,5
-
-! get coefficients for that standard linear solid
-! IMPROVE we use mu_v here even if there is some anisotropy
-! IMPROVE we should probably use an average value instead
-
- R_memory(i_memory,i_sls,:,:,:,ispec) = alphaval(i_sls) * &
- R_memory(i_memory,i_sls,:,:,:,ispec) + &
- factor_common(i_sls,1,1,1,iregion_selected) * muvstore(:,:,:,ispec) * &
- (betaval(i_sls) * epsilondev(i_memory,:,:,:,ispec) + &
- gammaval(i_sls) * epsilondev_loc(i_memory,:,:,:))
- enddo
- enddo
-
- endif
-
-! save deviatoric strain for Runge-Kutta scheme
- if(COMPUTE_AND_STORE_STRAIN) epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
-
- enddo ! spectral element loop
-
- end subroutine compute_forces_crust_mantle
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_inner_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_inner_core.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_inner_core.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,399 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 compute_forces_inner_core(displ,accel,xstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappavstore,muvstore,ibool,idoubling, &
- R_memory,epsilondev,&
- one_minus_sum_beta,alphaval,betaval,gammaval,factor_common, &
- vx,vy,vz,vnspec,COMPUTE_AND_STORE_STRAIN, AM_V)
-
- implicit none
-
- include "constants.h"
-
-! include values created by the mesher
-! done for performance only using static allocation to allow for loop unrolling
- include "OUTPUT_FILES/values_from_mesher.h"
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(:), pointer :: 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
-
-! for forward or backward simulations
- logical COMPUTE_AND_STORE_STRAIN
-
-! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ,accel
-
-! for attenuation
-! memory variables R_ij are stored at the local rather than global level
-! to allow for optimization of cache access by compiler
- integer i_sls,i_memory
- real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
-
-! variable lengths for factor_common and one_minus_sum_beta
- integer vx, vy, vz, vnspec
-
- real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
-
- real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: factor_common
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
-
-! array with the local to global mapping per slice
- integer, dimension(NSPEC_INNER_CORE) :: idoubling
-
-! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: xix,xiy,xiz, &
- etax,etay,etaz,gammax,gammay,gammaz
-
-! 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
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: kappavstore,muvstore
-
- integer ispec,iglob
- integer i,j,k,l
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
-
- real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
-
- real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
-
- real(kind=CUSTOM_REAL) hp1,hp2,hp3
- real(kind=CUSTOM_REAL) fac1,fac2,fac3
- real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
- real(kind=CUSTOM_REAL) kappal
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
-
- real(kind=CUSTOM_REAL) minus_sum_beta
-
- real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
- real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
- real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
-
-! for gravity
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: xstore
- integer iregion_selected
-
- real(kind=CUSTOM_REAL) radius_cr
-
-! ****************************************************
-! big loop over all spectral elements in the solid
-! ****************************************************
-
-! set acceleration to zero
- accel(:,:) = 0._CUSTOM_REAL
-
- do ispec = 1,NSPEC_INNER_CORE
-
-! exclude fictitious elements in central cube
- if(idoubling(ispec) /= IFLAG_IN_FICTITIOUS_CUBE) then
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- tempy1l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
-
- tempz1l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l = tempx1l + displ(1,iglob)*hp1
- tempy1l = tempy1l + displ(2,iglob)*hp1
- tempz1l = tempz1l + displ(3,iglob)*hp1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l = tempx2l + displ(1,iglob)*hp2
- tempy2l = tempy2l + displ(2,iglob)*hp2
- tempz2l = tempz2l + displ(3,iglob)*hp2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l = tempx3l + displ(1,iglob)*hp3
- tempy3l = tempy3l + displ(2,iglob)*hp3
- tempz3l = tempz3l + displ(3,iglob)*hp3
- enddo
-
-! get derivatives of ux, uy and uz with respect to x, y and z
-
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
-
-! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
- duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
- duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
- duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
-
- duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
- duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
- duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
-
-! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
-
-! compute deviatoric strain
- if (COMPUTE_AND_STORE_STRAIN) then
- epsilondev_loc(1,i,j,k) = duxdxl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(2,i,j,k) = duydyl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
- endif
-
- if(ATTENUATION_VAL) then
- radius_cr = xstore(ibool(i,j,k,ispec))
- call get_attenuation_index(idoubling(ispec), dble(radius_cr), iregion_selected, .TRUE., AM_V)
- minus_sum_beta = one_minus_sum_beta(1,1,1,iregion_selected) - 1.0
- endif ! ATTENUATION_VAL
-
- if(ANISOTROPIC_INNER_CORE_VAL) then
-
- else
-
-! inner core with no anisotropy, use kappav and muv for instance
-! layer with no anisotropy, use kappav and muv for instance
- kappal = kappavstore(i,j,k,ispec)
- mul = muvstore(i,j,k,ispec)
-
-! use unrelaxed parameters if attenuation
- if(ATTENUATION_VAL) then
- mul = mul * one_minus_sum_beta(1,1,1,iregion_selected)
- endif
-
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
-
-! compute stress sigma
-
- sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
-
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
-
- endif
-
-! subtract memory variables if attenuation
- if(ATTENUATION_VAL) then
- do i_sls = 1,N_SLS
- R_xx_val = R_memory(1,i_sls,i,j,k,ispec)
- R_yy_val = R_memory(2,i_sls,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val
- sigma_yy = sigma_yy - R_yy_val
- sigma_zz = sigma_zz + R_xx_val + R_yy_val
- sigma_xy = sigma_xy - R_memory(3,i_sls,i,j,k,ispec)
- sigma_xz = sigma_xz - R_memory(4,i_sls,i,j,k,ispec)
- sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
- enddo
- endif
-
-! form dot product with test vector, symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
-
- enddo
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempy1l = 0._CUSTOM_REAL
- tempz1l = 0._CUSTOM_REAL
-
- tempx2l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
-
- tempx3l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- fac1 = hprimewgll_xx(l,i)
- tempx1l = tempx1l + tempx1(l,j,k)*fac1
- tempy1l = tempy1l + tempy1(l,j,k)*fac1
- tempz1l = tempz1l + tempz1(l,j,k)*fac1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- fac2 = hprimewgll_yy(l,j)
- tempx2l = tempx2l + tempx2(i,l,k)*fac2
- tempy2l = tempy2l + tempy2(i,l,k)*fac2
- tempz2l = tempz2l + tempz2(i,l,k)*fac2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- fac3 = hprimewgll_zz(l,k)
- tempx3l = tempx3l + tempx3(i,j,l)*fac3
- tempy3l = tempy3l + tempy3(i,j,l)*fac3
- tempz3l = tempz3l + tempz3(i,j,l)*fac3
- enddo
-
- fac1 = wgllwgll_yz(j,k)
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
-
- sum_terms(1,i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
- sum_terms(2,i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
- sum_terms(3,i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
-
- enddo
- enddo
- enddo
-
-! sum contributions from each element to the global mesh and add gravity terms
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- accel(:,iglob) = accel(:,iglob) + sum_terms(:,i,j,k)
- enddo
- enddo
- enddo
-
-! use Runge-Kutta scheme to march memory variables in time
-! convention for attenuation
-! term in xx = 1
-! term in yy = 2
-! term in xy = 3
-! term in xz = 4
-! term in yz = 5
-! term in zz not computed since zero trace
-
- if(ATTENUATION_VAL) then
-
- do i_sls = 1,N_SLS
- do i_memory = 1,5
- R_memory(i_memory,i_sls,:,:,:,ispec) = &
- alphaval(i_sls) * &
- R_memory(i_memory,i_sls,:,:,:,ispec) + muvstore(:,:,:,ispec) * &
- factor_common(i_sls,1,1,1,iregion_selected) * &
- (betaval(i_sls) * &
- epsilondev(i_memory,:,:,:,ispec) + gammaval(i_sls) * epsilondev_loc(i_memory,:,:,:))
- enddo
- enddo
-
- endif
-
- if (COMPUTE_AND_STORE_STRAIN) then
-! save deviatoric strain for Runge-Kutta scheme
- epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
- endif
-
- endif ! end test to exclude fictitious elements in central cube
-
- enddo ! spectral element loop
-
- end subroutine compute_forces_inner_core
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_outer_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_outer_core.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_outer_core.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,224 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 compute_forces_outer_core(d_ln_density_dr_table, &
- displfluid,accelfluid,xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,ibool)
-
- implicit none
-
- include "constants.h"
-
-! include values created by the mesher
-! done for performance only using static allocation to allow for loop unrolling
- include "OUTPUT_FILES/values_from_mesher.h"
-
-! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: displfluid,accelfluid
-
-! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec_outer_core) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_outer_core) :: xix,xiy,xiz, &
- etax,etay,etaz,gammax,gammay,gammaz
-
-! 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
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: tempx1,tempx2,tempx3
-
-! for gravity
- integer int_radius
- double precision radius,theta,phi
- double precision cos_theta,sin_theta,cos_phi,sin_phi
- double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
- real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: xstore,ystore,zstore
-
- integer ispec,iglob
- integer i,j,k,l
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
- real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
-
- double precision grad_x_ln_rho,grad_y_ln_rho,grad_z_ln_rho
-! ****************************************************
-! big loop over all spectral elements in the fluid
-! ****************************************************
-
-! set acceleration to zero
- accelfluid(:) = 0._CUSTOM_REAL
-
- do ispec = 1,NSPEC_OUTER_CORE
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- iglob = ibool(i,j,k,ispec)
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- tempx1l = tempx1l + displfluid(ibool(l,j,k,ispec)) * hprime_xx(i,l)
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- tempx2l = tempx2l + displfluid(ibool(i,l,k,ispec)) * hprime_yy(j,l)
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- tempx3l = tempx3l + displfluid(ibool(i,j,l,ispec)) * hprime_zz(k,l)
- enddo
-
-! get derivatives of velocity potential with respect to x, y and z
-
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
-
-! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- dpotentialdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- dpotentialdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- dpotentialdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
-! add (chi/rho)grad(rho) term in no gravity case
-
-! With regards to the non-gravitating case: we cannot set N^2 = 0 *and* let g = 0.
-! We can *either* assume N^2 = 0 but keep gravity g, *or* we can assume that gravity
-! is negligible to begin with, as in our GJI 2002a, in which case N does not arise.
-! We get:
-!
-! \ddot\chi = \rho^{-1}\kappa\bdel\cdot(\bdel\chi+\chi\bdel\ln\rho)
-!
-! Then the displacement is
-!
-! \bu = \bdel\chi+\chi\bdel\ln\rho = \rho^{-1}\bdel(\rho\chi)
-!
-! and the pressure is
-!
-! p = -\rho\ddot{\chi}
-!
-! Thus in our 2002b GJI paper eqn (21) is wrong, and equation (41)
-! in our AGU monograph is incorrect; these equations should be replaced by
-!
-! \ddot\chi = \rho^{-1}\kappa\bdel\cdot(\bdel\chi+\chi\bdel\ln\rho)
-!
-! Note that the fluid potential we use in GJI 2002a differs from the one used here:
-!
-! \chi_GJI2002a = \rho\partial\t\chi
-!
-! such that
-!
-! \bv = \partial_t\bu=\rho^{-1}\bdel\chi_GJI2002a (GJI 2002a eqn 20)
-!
-! p = - \partial_t\chi_GJI2002a (GJI 2002a eqn 19)
-
-! use mesh coordinates to get theta and phi
-! x y z contain r theta phi
-
- radius = dble(xstore(iglob))
- theta = dble(ystore(iglob))
- phi = dble(zstore(iglob))
-
- cos_theta = dcos(theta)
- sin_theta = dsin(theta)
- cos_phi = dcos(phi)
- sin_phi = dsin(phi)
-
- int_radius = nint(radius * R_EARTH_KM * 10.d0)
-
-! grad(rho)/rho in Cartesian components
- grad_x_ln_rho = sin_theta * cos_phi * d_ln_density_dr_table(int_radius)
- grad_y_ln_rho = sin_theta * sin_phi * d_ln_density_dr_table(int_radius)
- grad_z_ln_rho = cos_theta * d_ln_density_dr_table(int_radius)
-
-! adding (chi/rho)grad(rho)
- dpotentialdxl = dpotentialdxl + displfluid(iglob) * grad_x_ln_rho
- dpotentialdyl = dpotentialdyl + displfluid(iglob) * grad_y_ln_rho
- dpotentialdzl = dpotentialdzl + displfluid(iglob) * grad_z_ln_rho
-
- tempx1(i,j,k) = jacobianl*(xixl*dpotentialdxl + xiyl*dpotentialdyl + xizl*dpotentialdzl)
- tempx2(i,j,k) = jacobianl*(etaxl*dpotentialdxl + etayl*dpotentialdyl + etazl*dpotentialdzl)
- tempx3(i,j,k) = jacobianl*(gammaxl*dpotentialdxl + gammayl*dpotentialdyl + gammazl*dpotentialdzl)
-
- enddo
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- tempx1l = tempx1l + tempx1(l,j,k) * hprimewgll_xx(l,i)
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- tempx2l = tempx2l + tempx2(i,l,k) * hprimewgll_yy(l,j)
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- tempx3l = tempx3l + tempx3(i,j,l) * hprimewgll_zz(l,k)
- enddo
-
-! sum contributions from each element to the global mesh and add gravity term
-
- iglob = ibool(i,j,k,ispec)
- accelfluid(iglob) = accelfluid(iglob) - (wgllwgll_yz(j,k)*tempx1l + wgllwgll_xz(i,k)*tempx2l + wgllwgll_xy(i,j)*tempx3l)
-
- enddo
- enddo
- enddo
-
- enddo ! spectral element loop
-
- end subroutine compute_forces_outer_core
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/constants.h
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/constants.h 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/constants.h 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,489 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! constants.h. Generated from constants.h.in by configure.
-
-!
-!--- user can modify parameters below
-!
-
-! deccrease the number of MPI messages by 3 but increase the size
-! of several MPI buffers by 3 but in order to do that
- logical, parameter :: FEWER_MESSAGES_LARGER_BUFFERS = .true.
-
-!
-! solver in single or double precision depending on the machine (4 or 8 bytes)
-!
-! ALSO CHANGE FILE precision.h ACCORDINGLY
-!
- integer, parameter :: SIZE_REAL = 4, SIZE_DOUBLE = 8
-
-! usually the size of integer and logical variables is the same as regular single-precision real variable
- integer, parameter :: SIZE_INTEGER = SIZE_REAL
- integer, parameter :: SIZE_LOGICAL = SIZE_REAL
-
-! set to SIZE_REAL to run in single precision
-! set to SIZE_DOUBLE to run in double precision (increases memory size by 2)
- integer, parameter :: CUSTOM_REAL = SIZE_REAL
-
-! input, output and main MPI I/O files
- integer, parameter :: ISTANDARD_OUTPUT = 6
- integer, parameter :: IIN = 40,IOUT = 41,IOUT_SAC = 903
-! local file unit for output of buffers
- integer, parameter :: IOUT_BUFFERS = 35
-! uncomment this to write messages to a text file
- integer, parameter :: IMAIN = 42
-! uncomment this to write messages to the screen (slows down the code)
-! integer, parameter :: IMAIN = ISTANDARD_OUTPUT
-
-! R_EARTH is the radius of the bottom of the oceans (radius of Earth in m)
- double precision, parameter :: R_EARTH = 6371000.d0
-! uncomment line below for PREM with oceans
-! double precision, parameter :: R_EARTH = 6368000.d0
-
-! average density in the full Earth to normalize equation
- double precision, parameter :: RHOAV = 5514.3d0
-
-! for topography/bathymetry model
-
-!!--- ETOPO5 5-minute model, smoothed Harvard version
-!! size of topography and bathymetry file
-! integer, parameter :: NX_BATHY = 4320,NY_BATHY = 2160
-!! resolution of topography file in minutes
-! integer, parameter :: RESOLUTION_TOPO_FILE = 5
-!! pathname of the topography file
-! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo5_smoothed_Harvard.dat'
-
-!--- ETOPO4 4-minute model created by subsampling and smoothing etopo-2
-! size of topography and bathymetry file
- integer, parameter :: NX_BATHY = 5400,NY_BATHY = 2700
-! resolution of topography file in minutes
- integer, parameter :: RESOLUTION_TOPO_FILE = 4
-! pathname of the topography file
- character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo4_smoothed_window_7.dat'
-
-!!--- ETOPO2 2-minute model, not implemented yet
-!! size of topography and bathymetry file
-! integer, parameter :: NX_BATHY = 10800,NY_BATHY = 5400
-!! resolution of topography file in minutes
-! integer, parameter :: RESOLUTION_TOPO_FILE = 2
-!! pathname of the topography file
-! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo2_smoothed_window7.dat'
-
-! maximum depth of the oceans in trenches and height of topo in mountains
-! to avoid taking into account spurious oscillations in global model ETOPO
- logical, parameter :: USE_MAXIMUM_HEIGHT_TOPO = .false.
- integer, parameter :: MAXIMUM_HEIGHT_TOPO = +20000
- logical, parameter :: USE_MAXIMUM_DEPTH_OCEANS = .false.
- integer, parameter :: MAXIMUM_DEPTH_OCEANS = -20000
-
-! minimum thickness in meters to include the effect of the oceans and topo
- double precision, parameter :: MINIMUM_THICKNESS_3D_OCEANS = 100.d0
-
-! number of GLL points in each direction of an element (degree plus one)
- integer, parameter :: NGLLX = 5
- integer, parameter :: NGLLY = NGLLX
- integer, parameter :: NGLLZ = NGLLX
-
-! flag to exclude elements that are too far from target in source detection
- logical, parameter :: USE_DISTANCE_CRITERION = .true.
-
-! flag to display detailed information about location of stations
- logical, parameter :: DISPLAY_DETAILS_STATIONS = .false.
-
-! maximum length of station and network name for receivers
- integer, parameter :: MAX_LENGTH_STATION_NAME = 32
- integer, parameter :: MAX_LENGTH_NETWORK_NAME = 8
-
-! we mimic a triangle of half duration equal to half_duration_triangle
-! using a Gaussian having a very close shape, as explained in Figure 4.2
-! of the manual. This source decay rate to mimic an equivalent triangle
-! was found by trial and error
- double precision, parameter :: SOURCE_DECAY_MIMIC_TRIANGLE = 1.628d0
-
-! maximum number of sources to locate simultaneously
- integer, parameter :: NSOURCES_SUBSET_MAX = 1000
-
-! distance threshold (in km) above which we consider that a receiver
-! is located outside the mesh and therefore excluded from the station list
- double precision, parameter :: THRESHOLD_EXCLUDE_STATION = 50.d0
-
-! the first doubling is implemented right below the Moho
-! it seems optimal to implement the three other doublings at these depths
-! in the mantle
- double precision, parameter :: DEPTH_SECOND_DOUBLING_OPTIMAL = 1650000.d0
-! in the outer core
- double precision, parameter :: DEPTH_THIRD_DOUBLING_OPTIMAL = 3860000.d0
-! in the outer core
- double precision, parameter :: DEPTH_FOURTH_DOUBLING_OPTIMAL = 5000000.d0
-
-! Boundary Mesh -- save Moho, 400, 670 km discontinuity topology files (in
-! the mesher) and use them for the computation of boundary kernel (in the solver)
- logical, parameter :: SAVE_BOUNDARY_MESH = .false.
-
-! this parameter must be set to .true. to compute anisotropic kernels
-! in crust and mantle (related to the 21 Cij in geographical coordinates)
-! default is .false. to compute isotropic kernels (related to alpha and beta)
- logical, parameter :: ANISOTROPIC_KL = .false.
-
-! print date and time estimate of end of run in another country,
-! in addition to local time.
-! 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.
-! The time difference with that remote location can be positive or negative
- logical, parameter :: ADD_TIME_ESTIMATE_ELSEWHERE = .false.
- integer, parameter :: HOURS_TIME_DIFFERENCE = +9
- integer, parameter :: MINUTES_TIME_DIFFERENCE = +0
-
-!
-!--- debugging flags
-!
-
-! flags to actually assemble with MPI or not
-! and to actually match fluid and solid regions of the Earth or not
-! should always be set to true except when debugging code
- logical, parameter :: ACTUALLY_ASSEMBLE_MPI_SLICES = .true.
- logical, parameter :: ACTUALLY_ASSEMBLE_MPI_CHUNKS = .true.
- logical, parameter :: ACTUALLY_COUPLE_FLUID_CMB = .true.
- logical, parameter :: ACTUALLY_COUPLE_FLUID_ICB = .true.
-
-!! DK DK UGLY added this in case we are running on MareNostrum in Barcelona
-!! DK DK UGLY because we then need some calls to the system to use GPFS
- logical, parameter :: RUN_ON_MARENOSTRUM_BARCELONA = .false.
-
-!------------------------------------------------------
-!----------- do not modify anything below -------------
-!------------------------------------------------------
-
-! on some processors (e.g. Pentiums) it is necessary to suppress underflows
-! by using a small initial field instead of zero
- logical, parameter :: FIX_UNDERFLOW_PROBLEM = .true.
-
-! some useful constants
- double precision, parameter :: PI = 3.141592653589793d0
- double precision, parameter :: TWO_PI = 2.d0 * PI
- double precision, parameter :: PI_OVER_FOUR = PI / 4.d0
-
-! to convert angles from degrees to radians
- double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0
-
-! 3-D simulation
- integer, parameter :: NDIM = 3
-
-! dimension of the boundaries of the slices
- integer, parameter :: NDIM2D = 2
-
-! number of nodes for 2D and 3D shape functions for hexahedra with 27 nodes
- integer, parameter :: NGNOD = 27, NGNOD2D = 9
-
-! gravitational constant
- double precision, parameter :: GRAV = 6.6723d-11
-
-! a few useful constants
- double precision, parameter :: ZERO = 0.d0,ONE = 1.d0,TWO = 2.d0,HALF = 0.5d0
-
- real(kind=CUSTOM_REAL), parameter :: &
- ONE_THIRD = 1._CUSTOM_REAL/3._CUSTOM_REAL, &
- TWO_THIRDS = 2._CUSTOM_REAL/3._CUSTOM_REAL, &
- FOUR_THIRDS = 4._CUSTOM_REAL/3._CUSTOM_REAL
-
-! very large and very small values
- double precision, parameter :: HUGEVAL = 1.d+30,TINYVAL = 1.d-9
-
-! very large real value declared independently of the machine
- real(kind=CUSTOM_REAL), parameter :: HUGEVAL_SNGL = 1.e+30_CUSTOM_REAL
-
-! very large integer value
- integer, parameter :: HUGEINT = 100000000
-
-! normalized radius of free surface
- double precision, parameter :: R_UNIT_SPHERE = ONE
-
-! same radius in km
- double precision, parameter :: R_EARTH_KM = R_EARTH / 1000.d0
-
-! fixed thickness of 3 km for PREM oceans
- double precision, parameter :: THICKNESS_OCEANS_PREM = 3000.d0 / R_EARTH
-
-! shortest radius at which crust is implemented (80 km depth)
-! to be constistent with the D80 discontinuity, we impose the crust only above it
- double precision, parameter :: R_DEEPEST_CRUST = (R_EARTH - 80000.d0) / R_EARTH
-
-! maximum number of chunks (full sphere)
- integer, parameter :: NCHUNKS_MAX = 6
-
-! define block type based upon chunk number (between 1 and 6)
-! do not change this numbering, chunk AB must be number 1 for central cube
- integer, parameter :: CHUNK_AB = 1
- integer, parameter :: CHUNK_AC = 2
- integer, parameter :: CHUNK_BC = 3
- integer, parameter :: CHUNK_AC_ANTIPODE = 4
- integer, parameter :: CHUNK_BC_ANTIPODE = 5
- integer, parameter :: CHUNK_AB_ANTIPODE = 6
-
-! maximum number of regions in the mesh
- integer, parameter :: MAX_NUM_REGIONS = 3
-
-! define flag for regions of the global Earth mesh
- integer, parameter :: IREGION_CRUST_MANTLE = 1
- integer, parameter :: IREGION_OUTER_CORE = 2
- integer, parameter :: IREGION_INNER_CORE = 3
-
-! define flag for elements
- integer, parameter :: IFLAG_CRUST = 1
-
- integer, parameter :: IFLAG_80_MOHO = 2
- integer, parameter :: IFLAG_220_80 = 3
- integer, parameter :: IFLAG_670_220 = 4
- integer, parameter :: IFLAG_MANTLE_NORMAL = 5
-
- integer, parameter :: IFLAG_OUTER_CORE_NORMAL = 6
-
- integer, parameter :: IFLAG_INNER_CORE_NORMAL = 7
- integer, parameter :: IFLAG_MIDDLE_CENTRAL_CUBE = 8
- integer, parameter :: IFLAG_BOTTOM_CENTRAL_CUBE = 9
- integer, parameter :: IFLAG_TOP_CENTRAL_CUBE = 10
- integer, parameter :: IFLAG_IN_FICTITIOUS_CUBE = 11
-
- integer, parameter :: NSPEC2D_XI_SUPERBRICK = 8
- integer, parameter :: NSPEC2D_ETA_SUPERBRICK = 8
- integer, parameter :: NSPEC2D_XI_SUPERBRICK_1L = 6
- integer, parameter :: NSPEC2D_ETA_SUPERBRICK_1L = 6
-
-! dummy flag used for mesh display purposes only
- integer, parameter :: IFLAG_DUMMY = 100
-
-! max number of layers that are used in the radial direction to build the full mesh
- integer, parameter :: MAX_NUMBER_OF_MESH_LAYERS = 15
-
-! define number of spectral elements and points in basic symmetric mesh doubling superbrick
- integer, parameter :: NSPEC_DOUBLING_SUPERBRICK = 32
- integer, parameter :: NGLOB_DOUBLING_SUPERBRICK = 67
- integer, parameter :: NSPEC_SUPERBRICK_1L = 28
- integer, parameter :: NGLOB_SUPERBRICK_1L = 58
- integer, parameter :: NGNOD_EIGHT_CORNERS = 8
-
-! define flag for reference 1D Earth model
- integer, parameter :: REFERENCE_MODEL_PREM = 1
- integer, parameter :: REFERENCE_MODEL_IASP91 = 2
- integer, parameter :: REFERENCE_MODEL_1066A = 3
- integer, parameter :: REFERENCE_MODEL_AK135 = 4
- integer, parameter :: REFERENCE_MODEL_REF = 5
- integer, parameter :: REFERENCE_MODEL_JP1D = 6
- integer, parameter :: REFERENCE_MODEL_SEA1D = 7
-
-! define flag for 3D Earth model
- integer, parameter :: THREE_D_MODEL_S20RTS = 1
- integer, parameter :: THREE_D_MODEL_S362ANI = 2
- integer, parameter :: THREE_D_MODEL_S362WMANI = 3
- integer, parameter :: THREE_D_MODEL_S362ANI_PREM = 4
- integer, parameter :: THREE_D_MODEL_S29EA = 5
- integer, parameter :: THREE_D_MODEL_SEA99_JP3D = 6
- integer, parameter :: THREE_D_MODEL_SEA99 = 7
- integer, parameter :: THREE_D_MODEL_JP3D = 8
-
-! define flag for regions of the global Earth for attenuation
- integer, parameter :: NUM_REGIONS_ATTENUATION = 5
-
- integer, parameter :: IREGION_ATTENUATION_INNER_CORE = 1
- integer, parameter :: IREGION_ATTENUATION_CMB_670 = 2
- integer, parameter :: IREGION_ATTENUATION_670_220 = 3
- integer, parameter :: IREGION_ATTENUATION_220_80 = 4
- integer, parameter :: IREGION_ATTENUATION_80_SURFACE = 5
- integer, parameter :: IREGION_ATTENUATION_UNDEFINED = 6
-
-! number of standard linear solids for attenuation
- integer, parameter :: N_SLS = 3
-
-! computation of standard linear solids in meshfem3D
-! ATTENUATION_COMP_RESOLUTION: Number of Digits after decimal
-! ATTENUATION_COMP_MAXIMUM: Maximum Q Value
- integer, parameter :: ATTENUATION_COMP_RESOLUTION = 1
- integer, parameter :: ATTENUATION_COMP_MAXIMUM = 5000
-
-! for lookup table for attenuation every 100 m in radial direction of Earth model
- integer, parameter :: NRAD_ATTENUATION = 70000
- double precision, parameter :: TABLE_ATTENUATION = R_EARTH_KM * 10.0d0
-
-! for determination of the attenuation period range
-! if this is set to .true. then the hardcoded values will be used
-! otherwise they are computed automatically from the Number of elements
-! This *may* be a useful parameter for Benchmarking against older versions
- logical, parameter :: ATTENUATION_RANGE_PREDEFINED = .false.
-
-! flag for the four edges of each slice and for the bottom edge
- integer, parameter :: XI_MIN = 1
- integer, parameter :: XI_MAX = 2
- integer, parameter :: ETA_MIN = 3
- integer, parameter :: ETA_MAX = 4
- integer, parameter :: BOTTOM = 5
-
-! flags to select the right corner in each slice
- integer, parameter :: ILOWERLOWER = 1
- integer, parameter :: ILOWERUPPER = 2
- integer, parameter :: IUPPERLOWER = 3
- integer, parameter :: IUPPERUPPER = 4
-
-! number of points in each AVS or OpenDX quadrangular cell for movies
- integer, parameter :: NGNOD2D_AVS_DX = 4
-
-! number of faces a given slice can share with other slices
-! this is at most 2, except when there is only once slice per chunk
-! in which case it is 4
- integer, parameter :: NUMFACES_SHARED = 2 !!!!! DK DK removed support for one slice only 4
-
-! number of corners a given slice can share with other slices
-! this is at most 1, except when there is only once slice per chunk
-! in which case it is 4
- integer, parameter :: NUMCORNERS_SHARED = 1 !!!!!! DK DK removed support for one slice only 4
-
-! number of layers in PREM
- integer, parameter :: NR = 640
-
-! smallest real number on many machines = 1.1754944E-38
-! largest real number on many machines = 3.4028235E+38
-! small negligible initial value to avoid very slow underflow trapping
-! but not too small to avoid trapping on velocity and acceleration in Newmark
- real(kind=CUSTOM_REAL), parameter :: VERYSMALLVAL = 1.E-24_CUSTOM_REAL
-
-! displacement threshold above which we consider that the code became unstable
- real(kind=CUSTOM_REAL), parameter :: STABILITY_THRESHOLD = 1.E+25_CUSTOM_REAL
-
-! geometrical tolerance for boundary detection
- double precision, parameter :: SMALLVAL = 0.00001d0
-
-! small tolerance for conversion from x y z to r theta phi
- double precision, parameter :: SMALL_VAL_ANGLE = 1.d-10
-
-! geometry tolerance parameter to calculate number of independent grid points
-! sensitive to actual size of model, assumes reference sphere of radius 1
-! this is an absolute value for normalized coordinates in the Earth
- double precision, parameter :: SMALLVALTOL = 1.d-10
-
-! do not use tags for MPI messages, use dummy tag instead
- integer, parameter :: itag = 0,itag2 = 0
-
-! for the Gauss-Lobatto-Legendre points and weights
- double precision, parameter :: GAUSSALPHA = 0.d0,GAUSSBETA = 0.d0
-
-! number of lines per source in CMTSOLUTION file
- integer, parameter :: NLINES_PER_CMTSOLUTION_SOURCE = 13
-
-! number of iterations to solve the non linear system for xi and eta
- integer, parameter :: NUM_ITER = 4
-
-! number of hours per day for rotation rate of the Earth
- double precision, parameter :: HOURS_PER_DAY = 24.d0
-
-! for lookup table for gravity every 100 m in radial direction of Earth model
- integer, parameter :: NRAD_GRAVITY = 70000
-
-!!!!!!!!!!!!!! parameters added for the thread-safe version of the code
-! number of layers in DATA/1066a/1066a.dat
- integer, parameter :: NR_1066A = 160
-
-! number of layers in DATA/ak135/ak135.dat
- integer, parameter :: NR_AK135 = 144
-
-! number of layers in DATA/s362ani/REF
- integer, parameter :: NR_REF = 750
-
-! number of layers in DATA/Lebedev_sea99 1D model
- integer, parameter :: NR_SEA1D = 163
-
-! three_d_mantle_model_constants
- integer, parameter :: NK = 20,NS = 20,ND = 1
-
-! Japan 3D model (Zhao, 1994) constants
- integer, parameter :: MPA=42,MRA=48,MHA=21,MPB=42,MRB=48,MHB=18
- integer, parameter :: MKA=2101,MKB=2101
-
-! The meaningful range of Zhao et al.'s model (1994) is as follows:
-! latitude : 32 - 45 N
-! longitude: 130-145 E
-! depth : 0 - 500 km
-! The deepest Moho beneath Japan is 40 km
- double precision,parameter :: LAT_MAX = 45.d0
- double precision,parameter :: LAT_MIN = 32.d0
- double precision,parameter :: LON_MAX = 145.d0
- double precision,parameter :: LON_MIN = 130.d0
- double precision,parameter :: DEP_MAX = 500.d0
-
-! crustal_model_constants
- ! crustal model parameters for crust2.0
- integer, parameter :: NKEYS_CRUST = 359
- integer, parameter :: NLAYERS_CRUST = 8
- integer, parameter :: NCAP_CRUST = 180
- ! use sedimentary layers of crust 2.0
- logical, parameter :: INCLUDE_SEDIMENTS_CRUST = .true.
-!!!!!!!!!!!!!! end of parameters added for the thread-safe version of the code
-
-! to inflate the central cube (set to 0.d0 for a non-inflated cube)
- double precision, parameter :: CENTRAL_CUBE_INFLATE_FACTOR = 0.41d0
-
-! for the stretching of crustal elements in the case of 3D models
- double precision, parameter :: MAX_RATIO_CRUST_STRETCHING = 0.6d0
-
-! to suppress the crustal layers (replaced by an extension of the mantle: R_EARTH is not modified, but no more crustal doubling)
- logical, parameter :: SUPPRESS_CRUSTAL_MESH = .false.
-
-! to add a fourth doubling at the bottom of the outer core
- logical, parameter :: ADD_4TH_DOUBLING = .false.
-
-! parameters to cut the doubling brick
-
-! this to cut the superbrick: 3 possibilities, 4 cases max / possibility
-! three possibilities: (cut in xi and eta) or (cut in xi) or (cut in eta)
-! case 1: (ximin and etamin) or ximin or etamin
-! case 2: (ximin and etamax) or ximax or etamax
-! case 3: ximax and etamin
-! case 4: ximax and etamax
- integer, parameter :: NB_CUT_CASE = 4
-
-! corner 1: ximin and etamin
-! corner 2: ximax and etamin
-! corner 3: ximax and etamax
-! corner 4: ximin and etamax
- integer, parameter :: NB_SQUARE_CORNERS = 4
-
-! two possibilities: xi or eta
-! face 1: ximin or etamin
-! face 2: ximax or etamax
- integer, parameter :: NB_SQUARE_EDGES_ONEDIR = 2
-
-! this for the geometry of the basic doubling brick
- integer, parameter :: NSPEC_DOUBLING_BASICBRICK = 8
- integer, parameter :: NGLOB_DOUBLING_BASICBRICK = 27
-
-! for Cuthill-McKee (1969) permutation
- logical, parameter :: PERFORM_CUTHILL_MCKEE = .false.
- integer, parameter :: NGNOD_HEXAHEDRA = 8
-! perform classical or multi-level Cuthill-McKee ordering
- logical, parameter :: CMcK_MULTI = .false.
-! maximum size if multi-level Cuthill-McKee ordering
- integer, parameter :: LIMIT_MULTI_CUTHILL = 50
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/convolve_source_timefunction.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/convolve_source_timefunction.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/convolve_source_timefunction.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,135 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
- program convolve_source_time_function
-
-!
-! convolve seismograms computed for a Heaviside with given source time function
-!
-
-! we mimic a triangle of half duration equal to half_duration_triangle
-! using a Gaussian having a very close shape, as explained in Figure 4.2
-! of the manual
-
- implicit none
-
- include "constants.h"
-
- integer :: i,j,N_j,number_remove,nlines
-
- double precision :: alpha,dt,tau_j,source,exponent,t1,t2,displ1,displ2,gamma,height,half_duration_triangle
-
- logical :: triangle
-
- double precision, dimension(:), allocatable :: time,sem,sem_fil
-
-! read file with number of lines in input
- open(unit=33,file='input_convolve_code.txt',status='old',action='read')
- read(33,*) nlines
- read(33,*) half_duration_triangle
- read(33,*) triangle
- close(33)
-
-! allocate arrays
- allocate(time(nlines),sem(nlines),sem_fil(nlines))
-
-! read the input seismogram
- do i = 1,nlines
- read(5,*) time(i),sem(i)
- enddo
-
-! define a Gaussian with the right exponent to mimic a triangle of equivalent half duration
- alpha = SOURCE_DECAY_MIMIC_TRIANGLE/half_duration_triangle
-
-! compute the time step
- dt = time(2) - time(1)
-
-! number of integers for which the source wavelet is different from zero
- if(triangle) then
- N_j = ceiling(half_duration_triangle/dt)
- else
- N_j = ceiling(1.5d0*half_duration_triangle/dt)
- endif
-
- do i = 1,nlines
-
- sem_fil(i) = 0.d0
-
- do j = -N_j,N_j
-
- if(i > j .and. i-j <= nlines) then
-
- tau_j = dble(j)*dt
-
-! convolve with a triangle
- if(triangle) then
- height = 1.d0 / half_duration_triangle
- if(abs(tau_j) > half_duration_triangle) then
- source = 0.d0
- else if (tau_j < 0.d0) then
- t1 = - N_j * dt
- displ1 = 0.d0
- t2 = 0.d0
- displ2 = height
- gamma = (tau_j - t1) / (t2 - t1)
- source= (1.d0 - gamma) * displ1 + gamma * displ2
- else
- t1 = 0.d0
- displ1 = height
- t2 = + N_j * dt
- displ2 = 0.d0
- gamma = (tau_j - t1) / (t2 - t1)
- source= (1.d0 - gamma) * displ1 + gamma * displ2
- endif
-
- else
-
-! convolve with a Gaussian
- exponent = alpha**2 * tau_j**2
- if(exponent < 50.d0) then
- source = alpha*exp(-exponent)/sqrt(PI)
- else
- source = 0.d0
- endif
-
- endif
-
- sem_fil(i) = sem_fil(i) + sem(i-j)*source*dt
-
- endif
-
- enddo
- enddo
-
-! compute number of samples to remove from end of seismograms
- number_remove = N_j + 1
- do i=1,nlines - number_remove
- write(*,*) sngl(time(i)),' ',sngl(sem_fil(i))
- enddo
-
- end program convolve_source_time_function
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/count_number_of_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/count_number_of_sources.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/count_number_of_sources.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,62 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 count_number_of_sources(NSOURCES)
-
-! count the total number of sources in the CMTSOLUTION file
-! there are NLINES_PER_CMTSOLUTION_SOURCE lines per source in that file
-
- implicit none
-
- include "constants.h"
-
- integer, intent(out) :: NSOURCES
-
- integer ios,icounter
-
- character(len=150) CMTSOLUTION,dummystring
-
- call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
-
- open(unit=1,file=CMTSOLUTION,iostat=ios,status='old',action='read')
- if(ios /= 0) stop 'error opening CMTSOLUTION file'
- icounter = 0
- do while(ios == 0)
- read(1,"(a)",iostat=ios) dummystring
- if(ios == 0) icounter = icounter + 1
- enddo
- close(1)
-
- 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'
-
- end subroutine count_number_of_sources
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_central_cube_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_central_cube_buffers.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_central_cube_buffers.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -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 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_chunk_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_chunk_buffers.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_chunk_buffers.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,1123 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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,LOCAL_PATH, &
- 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,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 "OUTPUT_FILES/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) :: 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) OUTPUT_FILES,LOCAL_PATH,ERR_MSG
-
-! array with the local to global mapping per slice
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
-! mask for ibool to mark points already found
- logical, dimension(:), allocatable :: mask_ibool
-
-! array to store points selected for the chunk face buffer
- integer, dimension(:), allocatable :: ibool_selected
-
- double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
-
-! arrays for sorting routine
- integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
- logical, dimension(:), allocatable :: ifseg
- double precision, dimension(:), allocatable :: work
-
-! pairs generated theoretically
-! four sides for each of the three types of messages
- integer, dimension(:), allocatable :: iproc_sender,iproc_receiver,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(:,:), allocatable :: 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,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
-
-! names of the data files for all the processors in MPI
- character(len=150) prname
-
-! 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')
-
-! allocate arrays for faces
- allocate(iproc_sender(NUMMSGS_FACES))
- allocate(iproc_receiver(NUMMSGS_FACES))
- allocate(npoin2D_send(NUMMSGS_FACES))
- allocate(npoin2D_receive(NUMMSGS_FACES))
-
-! allocate array for corners
- allocate(iprocscorners(3,NCORNERSCHUNKS))
- allocate(itypecorner(3,NCORNERSCHUNKS))
-
-! clear arrays allocated
- iproc_sender(:) = 0
- iproc_receiver(:) = 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
-
-! allocate arrays for message buffers with maximum size
- allocate(ibool_selected(NGLOB2DMAX_XY))
- allocate(xstore_selected(NGLOB2DMAX_XY))
- allocate(ystore_selected(NGLOB2DMAX_XY))
- allocate(zstore_selected(NGLOB2DMAX_XY))
- allocate(ind(NGLOB2DMAX_XY))
- allocate(ninseg(NGLOB2DMAX_XY))
- allocate(iglob(NGLOB2DMAX_XY))
- allocate(locval(NGLOB2DMAX_XY))
- allocate(ifseg(NGLOB2DMAX_XY))
- allocate(iwork(NGLOB2DMAX_XY))
- allocate(work(NGLOB2DMAX_XY))
-
-
-! allocate mask for ibool
- allocate(mask_ibool(nglob_ori))
-
- imsg = 0
-
- if(myrank == 0) then
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! file to store the list of processors for each message for faces
-!!! DK DK for merged open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='unknown')
-
- endif
-
-!!!!!!!!!! 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 = 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 == 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 == 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 == 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
- iproc_sender(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
- iproc_receiver(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
-
-! check that sender/receiver pair is ordered
- if(iproc_sender(imsg) > iproc_receiver(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,iproc_sender(imsg),iproc_receiver(imsg)
-
-! loop on sender/receiver (1=sender 2=receiver)
- do imode_comm=1,2
-
- if(imode_comm == 1) then
- iproc = iproc_sender(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 = iproc_receiver(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
-
-!---------------------------------------------------------------------
-
-! create the name of the database for each slice
- call create_name_database(prname,iproc,iregion_code,LOCAL_PATH)
-
-! open file for 2D buffer
-!! DK DK suppressed in the merged version
-! open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
-
-! 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)
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! read boundary parameters
-!! DK DK suppressed in the merged version
-! open(unit=IIN,file=prname(1:len_trim(prname))//'boundary.bin',status='old',action='read',form='unformatted')
-!! DK DK suppressed in the merged version read(IIN) nspec2D_xmin
-!! DK DK suppressed in the merged version read(IIN) nspec2D_xmax
-!! DK DK suppressed in the merged version read(IIN) nspec2D_ymin
-!! DK DK suppressed in the merged version read(IIN) nspec2D_ymax
-!! DK DK suppressed in the merged version read(IIN) njunk
-!! DK DK suppressed in the merged version read(IIN) njunk
-!! DK DK suppressed in the merged version
-!! DK DK suppressed in the merged version read(IIN) ibelm_xmin
-!! DK DK suppressed in the merged version read(IIN) ibelm_xmax
-!! DK DK suppressed in the merged version read(IIN) ibelm_ymin
-!! DK DK suppressed in the merged version read(IIN) ibelm_ymax
-!! DK DK suppressed in the merged version close(IIN)
-
-! read 1D buffers to remove corner points
-!! DK DK suppressed in the merged version
-! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='old',action='read')
-!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
-!! DK DK suppressed in the merged version read(IIN,*) ibool1D_leftxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
-!! DK DK suppressed in the merged version enddo
-!! DK DK suppressed in the merged version close(IIN)
-
-!! DK DK suppressed in the merged version
-! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='old',action='read')
-!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
-!! DK DK suppressed in the merged version read(IIN,*) ibool1D_rightxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
-!! DK DK suppressed in the merged version enddo
-!! DK DK suppressed in the merged version close(IIN)
-
-!! DK DK suppressed in the merged version
-! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='old',action='read')
-!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
-!! DK DK suppressed in the merged version read(IIN,*) ibool1D_leftxi_righteta(ipoin1D),xdummy,ydummy,zdummy
-!! DK DK suppressed in the merged version enddo
-!! DK DK suppressed in the merged version close(IIN)
-
-!! DK DK suppressed in the merged version
-! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='old',action='read')
-!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
-!! DK DK suppressed in the merged version read(IIN,*) ibool1D_rightxi_righteta(ipoin1D),xdummy,ydummy,zdummy
-!! DK DK suppressed in the merged version enddo
-!! DK DK suppressed in the merged version close(IIN)
-
-! 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
-!
-
-! synchronize all the processes to make sure all the buffers are ready
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-! 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,iproc_sender(imsg),MPI_COMM_WORLD,ier)
- if(myrank /= iproc_sender(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,iproc_receiver(imsg),MPI_COMM_WORLD,ier)
- if(myrank /= iproc_receiver(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
-
-! file to store the list of processors for each message for corners
-!!! DK DK for merged if(myrank == 0) open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='unknown')
-
-! 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 /= iproc_master_corners(imsg)) call exit_MPI(myrank,'this message should be for a master')
- if(imember_corner == 2 .and. myrank /= iproc_worker1_corners(imsg)) call exit_MPI(myrank,'this message should be for a worker1')
- if(imember_corner == 3 .and. myrank /= iproc_worker2_corners(imsg)) call exit_MPI(myrank,'this message should be for a worker2')
- icount_corners = 0
- do imsg2 = 1,imsg
- if(myrank == iproc_master_corners(imsg2) .or. &
- myrank == iproc_worker1_corners(imsg2) .or. &
- myrank == iproc_worker2_corners(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
-!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt'
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,1)
- else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
-!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt'
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,4)
- else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
-!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt'
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,2)
- else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
-!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt'
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,3)
- else
- call exit_MPI(myrank,'incorrect corner coordinates')
- endif
-
-! read 1D buffer for corner
-!! DK DK suppressed in the merged version open(unit=IIN,file=filename_in,status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL_my_corner
-!! DK DK suppressed in the merged version read(IIN,*) ibool1D(ipoin1D), &
-!! DK DK suppressed in the merged version xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
-
-!! 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')
-
-! write file with 1D buffer for corner
-!! DK DK suppressed in the merged version open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
-!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) NGLOB1D_RADIAL_my_corner
- do ipoin1D = 1,NGLOB1D_RADIAL_my_corner
-!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) ibool1D(ipoin1D), &
-!! DK DK suppressed in the merged version xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
-
-!! DK DK added this for merged version
- iboolcorner(ipoin1D,icount_corners) = ibool1D(ipoin1D)
-
- enddo
-!! DK DK suppressed in the merged version close(IOUT_BUFFERS)
-
-! end of section done only if right processor for MPI
- endif
-
- enddo
-
- enddo
-
-!!! DK DK for merged if(myrank == 0) close(IOUT)
-
-! deallocate arrays
- deallocate(iproc_sender)
- deallocate(iproc_receiver)
- deallocate(npoin2D_send)
- deallocate(npoin2D_receive)
-
- deallocate(iprocscorners)
- deallocate(itypecorner)
-
- deallocate(ibool_selected)
- deallocate(xstore_selected)
- deallocate(ystore_selected)
- deallocate(zstore_selected)
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iglob)
- deallocate(locval)
- deallocate(ifseg)
- deallocate(iwork)
- deallocate(work)
-
- deallocate(mask_ibool)
-
- end subroutine create_chunk_buffers
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_header_file.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_header_file.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,238 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 file OUTPUT_FILES/values_from_mesher.h based upon DATA/Par_file
-! in order to compile the solver with the right array sizes
-
- program xcreate_header_file
-
- 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,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
-
- 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,CASE_3D, &
- ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
-
- character(len=150) LOCAL_PATH,MODEL
-
-! parameters deduced from parameters read from file
- integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-! this for all the regions
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- nglob
-
- double precision :: static_memory_size
- character(len=150) HEADER_FILE
-
- integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
-
- integer :: iregion
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
- integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
- integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
-
-! ************** PROGRAM STARTS HERE **************
-
- call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
- print *
- print *,'creating file ', trim(HEADER_FILE), ' to compile solver with correct values'
-
-! 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,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
-
-! count the total number of sources in the CMTSOLUTION file
- call count_number_of_sources(NSOURCES)
-
- do iregion=1,MAX_NUM_REGIONS
- NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
- enddo
-
- if (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA) then
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + &
- maxval(DIFF_NSPEC1D_RADIAL(:,:))*(NGLLZ-1)
- endif
-
-! evaluate the amount of static memory needed by the solver
- call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
- TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
- ONE_CRUST,doubling_index,this_region_has_a_doubling,&
- ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
- NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
- NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
-
- NGLOB1D_RADIAL_TEMP(:) = &
- (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
-
-! create include file for the solver
- call save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
- INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP,&
- static_memory_size,&
- NGLOB1D_RADIAL_TEMP,&
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
- NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
- NPROC_XI,NPROC_ETA, &
- NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
-
- print *
- print *,'edit file OUTPUT_FILES/values_from_mesher.h to see some statistics about the mesh'
- print *
-
- print *,'number of processors = ',NPROCTOT
- print *
- print *,'maximum number of points per region = ',nglob(IREGION_CRUST_MANTLE)
- print *
- print *,'total elements per slice = ',sum(NSPEC)
- print *,'total points per slice = ',sum(nglob)
- print *
- print *,'number of time steps = ',NSTEP
- print *
-
- print *,'on NEC SX, make sure "loopcnt=" parameter'
-! use fused loops on NEC SX
- print *,'in Makefile is greater than max vector length = ',nglob(IREGION_CRUST_MANTLE)*NDIM
- print *
-
- print *,'approximate static memory needed by the solver:'
- print *,'----------------------------------------------'
- print *
- print *,'size of static arrays per slice = ',static_memory_size/1073741824.d0,' GB'
- print *
- print *,' (should be below and typically equal to 80% of 1.5 GB = 1.2 GB on pangu'
- print *,' at Caltech, and below and typically equal to 85% of 2 GB = 1.7 GB'
- print *,' on Marenostrum in Barcelona)'
- print *,' (if significantly more, the job will not run by lack of memory)'
- print *,' (if significantly less, you waste a significant amount of memory)'
- print *
- print *,'size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GB'
- print *,' = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TB'
- print *
-
- end program xcreate_header_file
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_list_files_chunks.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_list_files_chunks.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_list_files_chunks.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,558 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 the list of messages to assemble between chunks in files if more than one chunk
-
-!! DK DK for merged version: a lot of useless code / useless lines car probably be suppressed
-!! DK DK in this new routine below
-
- subroutine create_list_files_chunks(iregion_code, &
- nglob_ori,NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_CORNER, &
- myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS)
-
- 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 "OUTPUT_FILES/values_from_mesher.h"
-
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
-
- integer nglob,nglob_ori
- integer NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_my_corner
- integer myrank,NCHUNKS
-
- character(len=150) OUTPUT_FILES
-
-! pairs generated theoretically
-! four sides for each of the three types of messages
- integer, dimension(:), allocatable :: iproc_sender,iproc_receiver,npoin2D_send,npoin2D_receive
-
-! arrays to assemble the corners (3 processors for each corner)
- integer, dimension(:,:), allocatable :: 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,iside,imode_comm,iedge
-
- integer 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 **************
-
-! 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')
-
-! allocate arrays for faces
- allocate(iproc_sender(NUMMSGS_FACES))
- allocate(iproc_receiver(NUMMSGS_FACES))
- allocate(npoin2D_send(NUMMSGS_FACES))
- allocate(npoin2D_receive(NUMMSGS_FACES))
-
-! allocate array for corners
- allocate(iprocscorners(3,NCORNERSCHUNKS))
- allocate(itypecorner(3,NCORNERSCHUNKS))
-
-! clear arrays allocated
- iproc_sender(:) = 0
- iproc_receiver(:) = 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
-
- if(myrank == 0) then
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! file to store the list of processors for each message for faces
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='unknown')
-
- endif
-
-!!!!!!!!!! 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 = 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 == 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 == 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 == 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
- iproc_sender(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
- iproc_receiver(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
-
-! check that sender/receiver pair is ordered
- if(iproc_sender(imsg) > iproc_receiver(imsg)) call exit_MPI(myrank,'incorrect order in sender/receiver pair')
-
-! save message type and pair of processors in list of messages
- if(myrank == 0) write(IOUT,*) imsg_type,iproc_sender(imsg),iproc_receiver(imsg)
-
-! loop on sender/receiver (1=sender 2=receiver)
- do imode_comm=1,2
-
- if(imode_comm == 1) then
- iproc = iproc_sender(imsg)
- iedge = iproc_edge_send
-
- else if(imode_comm == 2) then
- iproc = iproc_receiver(imsg)
- iedge = iproc_edge_receive
-
- 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
-
-! 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
-
-! 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
-
- 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
-!
-
-! synchronize all the processes to make sure all the buffers are ready
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-!!!!!!!!!! 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
-
-! file to store the list of processors for each message for corners
- if(myrank == 0) open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='unknown')
-
-! 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
- 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
-
-! 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
-
-! pick the correct 1D buffer
-! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
- if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
-!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt'
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,1)
- else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
-!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt'
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,4)
- else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
-!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt'
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,2)
- else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
-!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt'
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,3)
- else
- call exit_MPI(myrank,'incorrect corner coordinates')
- endif
-
-! end of section done only if right processor for MPI
- endif
-
- enddo
-
- enddo
-
- if(myrank == 0) close(IOUT)
-
- end subroutine create_list_files_chunks
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_name_database.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_name_database.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_name_database.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,46 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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_name_database(prname,iproc,iregion_code,LOCAL_PATH)
-
-! create the name of the database for the mesher and the solver
-
- implicit none
-
- integer iproc,iregion_code
-
-! name of the database file
- character(len=150) prname,procname,LOCAL_PATH
-
-! create the name for the database of the current slide and region
- write(procname,"('/proc',i6.6,'_reg',i1,'_')") iproc,iregion_code
-
-! create full name with path
- prname = trim(LOCAL_PATH) // procname
-
- end subroutine create_name_database
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_regions_mesh.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_regions_mesh.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,2644 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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, &
- NGLOB2DMAX_XY, &
- myrank,LOCAL_PATH,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_region_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,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
- 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,perm,invperm)
-
-! 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 "OUTPUT_FILES/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_region_has_a_doubling
-
- integer :: ignod,ner_without_doubling,ispec_superbrick,ilayer,ilayer_loop,ix_elem,iy_elem,iz_elem, &
- ifirst_region,ilast_region,ratio_divide_central_cube
- integer, dimension(:), allocatable :: perm_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(:), pointer :: 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,HONOR_1D_SPHERICAL_MOHO
-
- double precision R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO, &
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
-
- character(len=150) LOCAL_PATH,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 and weights of integration
- double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
-
-! 3D shape functions and their derivatives
- double precision, dimension(:,:,:,:), allocatable :: shape3D
- double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
-
-! 2D shape functions and their derivatives
- double precision, dimension(:,:,:), allocatable :: shape2D_x,shape2D_y,shape2D_bottom,shape2D_top
- double precision, dimension(:,:,:,:), allocatable :: dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top
-
-! 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,r1,r2,r3,r4,r5,r6,r7,r8
-
-! for model density and anisotropy
- integer nspec_ani
-!! DK DK changed this for the merged version
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: 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(:,:,:,:), allocatable :: &
- 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(:,:), allocatable :: 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(:), allocatable :: locval
- logical, dimension(:), allocatable :: ifseg
- double precision, dimension(:), allocatable :: 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(:), allocatable :: rmass_ocean_load
-
-! mask to sort ibool
- integer, dimension(:), allocatable :: mask_ibool
- integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
- integer :: inumber
-
-! 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(:,:), allocatable :: iMPIcut_xi,iMPIcut_eta
-
-! Stacey, indices for Clayton-Engquist absorbing conditions
- integer, dimension(:,:), allocatable :: nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
-
-! name of the database file
- character(len=150) prname
-
-! 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(:,:,:,:), allocatable :: Qmu_store
- double precision, dimension(:,:,:,:,:), allocatable :: 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,cpt,first_layer_aniso,last_layer_aniso,FIRST_ELT_NON_ANISO
- double precision, dimension(:,:), allocatable :: stretch_tab
-
- integer :: NGLOB2DMAX_XY
-
- integer :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
-
- 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)
-
-! now perform two passes in this part to be able to save memory
- integer :: ipass
-
-! Boundary Mesh
- integer nex_eta_moho
- integer, dimension(:), allocatable :: ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
- ibelm_670_top,ibelm_670_bot
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_moho,normal_400,normal_670
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_moho,jacobian2D_400,jacobian2D_670
- integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot
- double precision r_moho,r_400,r_670
- logical :: is_superbrick
-
-! added for Cuthill McKee permutation
-! integer, dimension(:), allocatable :: perm,perm_tmp,temp_array_1D_int
-!! DK DK added this for merged version, as a quick patch
- integer, dimension(nspec) :: perm,invperm
- integer, dimension(:), allocatable :: perm_tmp,temp_array_1D_int
- logical, dimension(:,:), allocatable :: temp_array_2D_log
- integer, dimension(:,:,:,:), allocatable :: temp_array_int
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: temp_array_real
- double precision, dimension(:,:,:,:), allocatable :: temp_array_dble
- double precision, dimension(:,:,:,:,:), allocatable :: temp_array_dble_5dim
-!! DK DK added this for merged version
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: temp_array_xelm_yelm_zelm
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: temp_rmass
-
-! 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)
-
-! create the name for the database of the current slide and region
- call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
-
-! Attenuation
- if(ATTENUATION .and. ATTENUATION_3D) then
- T_c_source = AM_V%QT_c_source
- tau_s(:) = AM_V%Qtau_s(:)
- allocate(Qmu_store(NGLLX,NGLLY,NGLLZ,nspec),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
-
- allocate(tau_e_store(N_SLS,NGLLX,NGLLY,NGLLZ,nspec),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
- else
- allocate(Qmu_store(1,1,1,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
-
- allocate(tau_e_store(N_SLS,1,1,1,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
-
- Qmu_store(1,1,1,1) = 0.0d0
- tau_e_store(:,1,1,1,1) = 0.0d0
- endif
-
-! Gauss-Lobatto-Legendre points of integration
- allocate(xigll(NGLLX),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
-
- allocate(yigll(NGLLY),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
-
- allocate(zigll(NGLLZ),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
-
-! Gauss-Lobatto-Legendre weights of integration
- allocate(wxgll(NGLLX),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
-
- allocate(wygll(NGLLY),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
-
- allocate(wzgll(NGLLZ),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
-
-! 3D shape functions and their derivatives
- allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),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
-
- allocate(dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ),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
-
-
-! 2D shape functions and their derivatives
- allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ),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
-
- allocate(shape2D_y(NGNOD2D,NGLLX,NGLLZ),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
-
- allocate(shape2D_bottom(NGNOD2D,NGLLX,NGLLY),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
-
- allocate(shape2D_top(NGNOD2D,NGLLX,NGLLY),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
-
- allocate(dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),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
-
- allocate(dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ),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
-
- allocate(dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),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
-
- allocate(dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY),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
-
-
-! array with model density
-!! DK DK changed this for the merged version
- allocate(rhostore_local(NGLLX,NGLLY,NGLLZ),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
-
-!! DK DK added this for the merged version
- allocate(kappavstore_local(NGLLX,NGLLY,NGLLZ),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
-
-
-! Stacey
- if(NCHUNKS /= 6) then
- nspec_stacey = nspec
- else
- nspec_stacey = 1
- endif
- allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey),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
-
- allocate(rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey),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
-
-
- 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
-
- allocate(c11store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c12store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c13store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c14store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c15store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c16store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c22store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c23store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c24store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c25store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c26store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c33store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c34store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c35store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c36store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c44store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c45store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c46store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c55store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c56store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
- allocate(c66store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
-
-
-! boundary locator
- allocate(iboun(6,nspec),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
-
-
-! Stacey
- allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX),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
-
- allocate(nimax(2,NSPEC2DMAX_YMIN_YMAX),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
-
- allocate(njmin(2,NSPEC2DMAX_XMIN_XMAX),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
-
- allocate(njmax(2,NSPEC2DMAX_XMIN_XMAX),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
-
- allocate(nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),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
-
- allocate(nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX),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
-
-
-! MPI cut-planes parameters along xi and along eta
- allocate(iMPIcut_xi(2,nspec),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
-
- allocate(iMPIcut_eta(2,nspec),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
-
-
-! 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_region = 1
- ilast_region = 10 + layer_shift
-
- else if(iregion_code == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_shift
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
-
- else if(iregion_code == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
-
- else
- call exit_MPI(myrank,'incorrect region code detected')
-
- endif
-
-! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
- if (ONE_CRUST) then
- first_layer_aniso=2
- last_layer_aniso=3
- nb_layer_above_aniso = 1
- else
- first_layer_aniso=3
- last_layer_aniso=4
- nb_layer_above_aniso = 2
- endif
- allocate (perm_layer(ifirst_region:ilast_region),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
-
- perm_layer = (/ (i, i=ilast_region,ifirst_region,-1) /)
- if(iregion_code == IREGION_CRUST_MANTLE) then
- cpt=3
- perm_layer(1)=first_layer_aniso
- perm_layer(2)=last_layer_aniso
- do i = ilast_region,ifirst_region,-1
- if (i/=first_layer_aniso .and. i/=last_layer_aniso) then
- perm_layer(cpt) = i
- cpt=cpt+1
- endif
- 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
-
-! boundary mesh
- if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
- allocate(ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO),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
-
- allocate(ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400),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
-
- allocate(ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670),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
-
- allocate(normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO),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
-
- allocate(normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400),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
-
- allocate(normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670),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
-
- allocate(jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO),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
-
- allocate(jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400),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
-
- allocate(jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670),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
-
-
- ispec2D_moho_top = 0; ispec2D_moho_bot = 0
- ispec2D_400_top = 0; ispec2D_400_bot = 0
- ispec2D_670_top = 0; ispec2D_670_bot = 0
-
- nex_eta_moho = NEX_PER_PROC_ETA
-
- r_moho = RMOHO/R_EARTH; r_400 = R400 / R_EARTH; r_670 = R670/R_EARTH
-
- 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_region,ilast_region
-
- ilayer = perm_layer(ilayer_loop)
-
-! determine the radii that define the shell
- rmin = rmins(ilayer)
- rmax = rmaxs(ilayer)
-
- if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==3) then
- FIRST_ELT_NON_ANISO = ispec+1
- endif
- if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==(ilast_region-nb_layer_above_aniso+1)) then
- FIRST_ELT_ABOVE_ANISO = ispec+1
- endif
-
- 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_region_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_region) then
- iboun(6,ispec)= .true.
- endif
- if (iz_elem == 1 .and. ilayer == ilast_region) 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)
-
-! save the radii of the nodes before modified through compute_element_properties()
- if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
- r1=sqrt(xelm(1)**2+yelm(1)**2+zelm(1)**2)
- r2=sqrt(xelm(2)**2+yelm(2)**2+zelm(2)**2)
- r3=sqrt(xelm(3)**2+yelm(3)**2+zelm(3)**2)
- r4=sqrt(xelm(4)**2+yelm(4)**2+zelm(4)**2)
- r5=sqrt(xelm(5)**2+yelm(5)**2+zelm(5)**2)
- r6=sqrt(xelm(6)**2+yelm(6)**2+zelm(6)**2)
- r7=sqrt(xelm(7)**2+yelm(7)**2+zelm(7)**2)
- r8=sqrt(xelm(8)**2+yelm(8)**2+zelm(8)**2)
- 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"
-
-! boundary mesh
- if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
- is_superbrick=.false.
- ispec_superbrick=0
- call get_jacobian_discontinuities(myrank,ispec,ix_elem,iy_elem,rmin,rmax,r1,r2,r3,r4,r5,r6,r7,r8, &
- xstore(:,:,:,ispec),ystore(:,:,:,ispec),zstore(:,:,:,ispec),dershape2D_bottom, &
- ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
- normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
- ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
- NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,r_moho,r_400,r_670, &
- is_superbrick,USE_ONE_LAYER_SB,ispec_superbrick,nex_eta_moho,HONOR_1D_SPHERICAL_MOHO)
- endif
-
-! 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_region_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_region .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 & 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 & 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_region) then
- iboun(6,ispec)= iboun_sb(ispec_superbrick,6)
- endif
- if (ilayer==ilast_region .and. iz_elem==1) then
- iboun(5,ispec)= iboun_sb(ispec_superbrick,5)
- endif
-
-! define the doubling flag of this element
- if(iregion_code /= IREGION_OUTER_CORE) idoubling(ispec) = doubling_index(ilayer)
-
-! save the radii of the nodes before modified through compute_element_properties()
- if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
- r1=sqrt(xelm(1)**2+yelm(1)**2+zelm(1)**2)
- r2=sqrt(xelm(2)**2+yelm(2)**2+zelm(2)**2)
- r3=sqrt(xelm(3)**2+yelm(3)**2+zelm(3)**2)
- r4=sqrt(xelm(4)**2+yelm(4)**2+zelm(4)**2)
- r5=sqrt(xelm(5)**2+yelm(5)**2+zelm(5)**2)
- r6=sqrt(xelm(6)**2+yelm(6)**2+zelm(6)**2)
- r7=sqrt(xelm(7)**2+yelm(7)**2+zelm(7)**2)
- r8=sqrt(xelm(8)**2+yelm(8)**2+zelm(8)**2)
- 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"
-
-! boundary mesh
- if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
- is_superbrick=.true.
- call get_jacobian_discontinuities(myrank,ispec,ix_elem,iy_elem,rmin,rmax,r1,r2,r3,r4,r5,r6,r7,r8, &
- xstore(:,:,:,ispec),ystore(:,:,:,ispec),zstore(:,:,:,ispec),dershape2D_bottom, &
- ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
- normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
- ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
- NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,r_moho,r_400,r_670, &
- is_superbrick,USE_ONE_LAYER_SB,ispec_superbrick,nex_eta_moho,HONOR_1D_SPHERICAL_MOHO)
- endif
-
-! 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
- endif
-
- endif
- deallocate (perm_layer,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate perm_layer in create_regions_mesh ier=",ier
- 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
-
- ! allocate memory for arrays
- allocate(locval(npointot),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
-
- allocate(ifseg(npointot),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
-
- allocate(xp(npointot),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
-
- allocate(yp(npointot),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
-
- allocate(zp(npointot),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
-
- 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)
-
- deallocate(xp,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate xp in create_regions_mesh ier=",ier
- endif
-
- deallocate(yp,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate yp in create_regions_mesh ier=",ier
- endif
-
- deallocate(zp,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate zp in create_regions_mesh ier=",ier
- endif
-
-
- ! 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
- allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate copy_ibool_ori in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(mask_ibool(nglob),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate mask_ibool in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-
- 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
-
- deallocate(copy_ibool_ori,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate copy_ibool_ori in create_regions_mesh ier=",ier
- endif
-
- deallocate(mask_ibool,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate mask_ibool in create_regions_mesh ier=",ier
- endif
-
-
- 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, &
- xstore,ystore,zstore,ifseg,npointot, &
- NSPEC2D_ETA_FACE,iregion_code,NGLOB2DMAX_XY,nglob,iboolleft_xi,iboolright_xi,NGLOB2DMAX_XMIN_XMAX,npoin2D_xi)
- call get_MPI_cutplanes_eta(myrank,nspec,iMPIcut_eta,ibool, &
- xstore,ystore,zstore,ifseg,npointot, &
- NSPEC2D_XI_FACE,iregion_code,NGLOB2DMAX_XY,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)
-
- deallocate(locval,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate locval in create_regions_mesh ier=",ier
- endif
-
- deallocate(ifseg,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate ifseg in create_regions_mesh ier=",ier
- endif
-
-!! DK DK for merged code, copied here to be able to create mass matrix in right order
- if (PERFORM_CUTHILL_MCKEE) then
-!!!!!!!!!!!!!!!!!!!! allocate(perm(nspec))
- if(iregion_code == IREGION_CRUST_MANTLE) then
- ! do not permute anisotropic elements
- perm(1:FIRST_ELT_NON_ANISO-1) = (/ (i,i=1,FIRST_ELT_NON_ANISO-1) /)
-
- ! no more connectivity between layers below and above the anisotropic layers => 2 permutations
- ! permute the bottom of the region : below the aniso layers
- allocate(perm_tmp(FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate perm_tmp in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- call get_perm(ibool(:,:,:,FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1),perm_tmp,LIMIT_MULTI_CUTHILL,&
- (FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO),nglob,.true.,.false.)
- perm(FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1) = perm_tmp(:)+(FIRST_ELT_NON_ANISO-1)
- deallocate(perm_tmp,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate perm_tmp in create_regions_mesh ier=",ier
- endif
-
- ! permute the top of the region : above the aniso layers
- allocate(perm_tmp(nspec-FIRST_ELT_ABOVE_ANISO+1),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate perm_tmp in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- call get_perm(ibool(:,:,:,FIRST_ELT_ABOVE_ANISO:nspec),perm_tmp,LIMIT_MULTI_CUTHILL,&
- (nspec-FIRST_ELT_ABOVE_ANISO+1),nglob,.true.,.false.)
- perm(FIRST_ELT_ABOVE_ANISO:nspec) = perm_tmp(:)+(FIRST_ELT_ABOVE_ANISO-1)
- deallocate(perm_tmp,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate perm_tmp in create_regions_mesh ier=",ier
- endif
- else
- ! the 3 last parameters are : PERFORM_CUTHILL_MCKEE,INVERSE,FACE
- call get_perm(ibool,perm,LIMIT_MULTI_CUTHILL,nspec,nglob,.true.,.false.)
- endif
-!!!!!!!!!!!!!!!!!!!! deallocate(perm)
-!! DK DK create inverse permutation
- if(minval(perm) /= 1) stop 'minval of perm must be 1'
- if(maxval(perm) /= nspec) stop 'maxval of perm must be nspec'
- invperm(:) = -1
- do ispec=1,nspec
- if(invperm(perm(ispec)) == -1) then
- invperm(perm(ispec)) = ispec
- else
- stop 'value already found, permutation is not bijective'
- endif
- enddo
- if(minval(invperm) /= 1) stop 'minval of invperm must be 1'
- if(maxval(invperm) /= nspec) stop 'maxval of invperm must be nspec'
- endif
-!! DK DK for merged code, copied here to be able to create mass matrix in right order
-
-! 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
-
-! ***************************************************
-! Cuthill McKee permutation
-! ***************************************************
- if (PERFORM_CUTHILL_MCKEE) then
-!!!!!!!!!!!!!!!!!!! allocate(perm(nspec))
-! if(iregion_code == IREGION_CRUST_MANTLE) then
-! ! do not permute anisotropic elements
-! perm(1:FIRST_ELT_NON_ANISO-1) = (/ (i,i=1,FIRST_ELT_NON_ANISO-1) /)
-
-! ! no more connectivity between layers below and above the anisotropic layers => 2 permutations
-! ! permute the bottom of the region : below the aniso layers
-! allocate(perm_tmp(FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO))
-! call get_perm(ibool(:,:,:,FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1),perm_tmp,LIMIT_MULTI_CUTHILL,&
-! (FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO),nglob,.true.,.false.)
-! perm(FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1) = perm_tmp(:)+(FIRST_ELT_NON_ANISO-1)
-! deallocate(perm_tmp)
-
-! ! permute the top of the region : above the aniso layers
-! allocate(perm_tmp(nspec-FIRST_ELT_ABOVE_ANISO+1))
-! call get_perm(ibool(:,:,:,FIRST_ELT_ABOVE_ANISO:nspec),perm_tmp,LIMIT_MULTI_CUTHILL,&
-! (nspec-FIRST_ELT_ABOVE_ANISO+1),nglob,.true.,.false.)
-! perm(FIRST_ELT_ABOVE_ANISO:nspec) = perm_tmp(:)+(FIRST_ELT_ABOVE_ANISO-1)
-! deallocate(perm_tmp)
-! else
-! ! the 3 last parameters are : PERFORM_CUTHILL_MCKEE,INVERSE,FACE
-! call get_perm(ibool,perm,LIMIT_MULTI_CUTHILL,nspec,nglob,.true.,.false.)
-! endif
-
- ! permutation of xstore, ystore, zstore, rhostore, kappavstore, kappahstore,
- ! muvstore, muhstore, eta_anisostore
-
- allocate(temp_array_dble(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate temp_array_dble in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- if(ATTENUATION .and. ATTENUATION_3D) then
- call permute_elements_dble(Qmu_store,temp_array_dble,perm,nspec)
- allocate(temp_array_dble_5dim(N_SLS,NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate permute_elements_dble in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- temp_array_dble_5dim(:,:,:,:,:) = tau_e_store(:,:,:,:,:)
- do i = 1,nspec
- tau_e_store(:,:,:,:,perm(i)) = temp_array_dble_5dim(:,:,:,:,i)
- enddo
- deallocate(temp_array_dble_5dim,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate temp_array_dble_5dim in create_regions_mesh ier=",ier
- endif
-
- endif
- call permute_elements_dble(xstore,temp_array_dble,perm,nspec)
- call permute_elements_dble(ystore,temp_array_dble,perm,nspec)
- call permute_elements_dble(zstore,temp_array_dble,perm,nspec)
- deallocate(temp_array_dble,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate temp_array_dble in create_regions_mesh ier=",ier
- endif
-
-!! DK DK added this for merged code
- allocate(temp_array_xelm_yelm_zelm(NGNOD,nspec),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate temp_array_xelm_yelm_zelm in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- call permute_elements_xelm_yelm_zelm(xelm_store,temp_array_xelm_yelm_zelm,perm,nspec)
- call permute_elements_xelm_yelm_zelm(yelm_store,temp_array_xelm_yelm_zelm,perm,nspec)
- call permute_elements_xelm_yelm_zelm(zelm_store,temp_array_xelm_yelm_zelm,perm,nspec)
-
- deallocate(temp_array_xelm_yelm_zelm,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate temp_array_xelm_yelm_zelm in create_regions_mesh ier=",ier
- endif
-
- allocate(temp_array_real(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate temp_array_real in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- if(ABSORBING_CONDITIONS .and. NCHUNKS /= 6) then
- call permute_elements_real(rho_vp,temp_array_real,perm,nspec)
- call permute_elements_real(rho_vs,temp_array_real,perm,nspec)
- endif
- if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
- (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) then
- call permute_elements_real(c11store,temp_array_real,perm,nspec)
- call permute_elements_real(c12store,temp_array_real,perm,nspec)
- call permute_elements_real(c13store,temp_array_real,perm,nspec)
- call permute_elements_real(c14store,temp_array_real,perm,nspec)
- call permute_elements_real(c15store,temp_array_real,perm,nspec)
- call permute_elements_real(c16store,temp_array_real,perm,nspec)
- call permute_elements_real(c22store,temp_array_real,perm,nspec)
- call permute_elements_real(c23store,temp_array_real,perm,nspec)
- call permute_elements_real(c24store,temp_array_real,perm,nspec)
- call permute_elements_real(c25store,temp_array_real,perm,nspec)
- call permute_elements_real(c26store,temp_array_real,perm,nspec)
- call permute_elements_real(c33store,temp_array_real,perm,nspec)
- call permute_elements_real(c34store,temp_array_real,perm,nspec)
- call permute_elements_real(c35store,temp_array_real,perm,nspec)
- call permute_elements_real(c36store,temp_array_real,perm,nspec)
- call permute_elements_real(c44store,temp_array_real,perm,nspec)
- call permute_elements_real(c45store,temp_array_real,perm,nspec)
- call permute_elements_real(c46store,temp_array_real,perm,nspec)
- call permute_elements_real(c55store,temp_array_real,perm,nspec)
- call permute_elements_real(c56store,temp_array_real,perm,nspec)
- call permute_elements_real(c66store,temp_array_real,perm,nspec)
- endif
-!! DK DK added this for merged version
- if(iregion_code /= IREGION_OUTER_CORE) then
- call permute_elements_real(kappavstore,temp_array_real,perm,nspec)
- call permute_elements_real(muvstore,temp_array_real,perm,nspec)
- if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) then
- if(minval(perm(1:NSPECMAX_TISO_MANTLE)) /= 1) stop 'minval perm for aniso should be 1'
- if(maxval(perm(1:NSPECMAX_TISO_MANTLE)) /= NSPECMAX_TISO_MANTLE) &
- stop 'maxval perm for aniso should be NSPECMAX_TISO_MANTLE'
- call permute_elements_real(kappahstore,temp_array_real,perm,NSPECMAX_TISO_MANTLE)
- call permute_elements_real(muhstore,temp_array_real,perm,NSPECMAX_TISO_MANTLE)
- call permute_elements_real(eta_anisostore,temp_array_real,perm,NSPECMAX_TISO_MANTLE)
- endif
- endif
-
-!! DK DK added this for merged version: attempt to permute mass matrix
-! 333333333333333
- allocate(temp_rmass(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate temp_rmass in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-! allocate(temp_rmass(nglob))
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-! temp_rmass(ibool(i,j,k,perm(ispec))) = rmass(ibool(i,j,k,ispec))
- temp_rmass(i,j,k,ispec) = rmass(ibool(i,j,k,ispec))
- enddo
- enddo
- enddo
- enddo
-! rmass(:) = temp_rmass(:)
- call permute_elements_real(temp_rmass,temp_array_real,perm,nspec)
-! do ispec = 1,nspec
-! do k = 1,NGLLZ
-! do j = 1,NGLLY
-! do i = 1,NGLLX
-! rmass(ibool(i,j,k,ispec)) = temp_rmass(i,j,k,ispec)
-! enddo
-! enddo
-! enddo
-! enddo
-! deallocate(temp_rmass)
-
- deallocate(temp_array_real,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate temp_array_real in create_regions_mesh ier=",ier
- endif
-
- ! permutation of ibool
- allocate(temp_array_int(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate temp_array_int in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- call permute_elements_integer(ibool,temp_array_int,perm,nspec)
- deallocate(temp_array_int,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate temp_array_int in create_regions_mesh ier=",ier
- endif
-
-!! DK DK added this for merged version: attempt to permute mass matrix
-! 333333333333333
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- rmass(ibool(i,j,k,ispec)) = temp_rmass(i,j,k,ispec)
- enddo
- enddo
- enddo
- enddo
- deallocate(temp_rmass,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate temp_rmass in create_regions_mesh ier=",ier
- endif
-
-! deallocate(temp_array_real)
-
- ! permutation of iMPIcut_*
- allocate(temp_array_2D_log(2,nspec),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate temp_array_2D_log in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- temp_array_2D_log(:,:) = iMPIcut_xi(:,:)
- do i = 1,nspec
- iMPIcut_xi(:,perm(i)) = temp_array_2D_log(:,i)
- enddo
- temp_array_2D_log(:,:) = iMPIcut_eta(:,:)
- do i = 1,nspec
- iMPIcut_eta(:,perm(i)) = temp_array_2D_log(:,i)
- enddo
-
- deallocate(temp_array_2D_log,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate temp_array_2D_log in create_regions_mesh ier=",ier
- endif
-
- ! permutation of iboun
- allocate(temp_array_2D_log(6,nspec),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate temp_array_2D_log in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- temp_array_2D_log(:,:) = iboun(:,:)
- do i = 1,nspec
- iboun(:,perm(i)) = temp_array_2D_log(:,i)
- enddo
-
- deallocate(temp_array_2D_log,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate temp_array_2D_log in create_regions_mesh ier=",ier
- endif
-
-
- ! permutation of idoubling
-!! DK DK added this for merged version because array not allocated in the outer core
- if(iregion_code /= IREGION_OUTER_CORE) then
- allocate(temp_array_1D_int(nspec),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate temp_array_1D_int in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- temp_array_1D_int(:) = idoubling(:)
- do i = 1,nspec
- idoubling(perm(i)) = temp_array_1D_int(i)
- enddo
- deallocate(temp_array_1D_int,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate temp_array_1D_int in create_regions_mesh ier=",ier
- endif
- endif
-
-!!!!!!!!!!!!!!!!!!! deallocate(perm)
- endif
-
-! ***************************************************
-! end of Cuthill McKee permutation
-! ***************************************************
-
- 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
- allocate(rmass_ocean_load(nglob_oceans),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate rmass_ocean_load in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-! 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)
-
-! compute local height of oceans
- if(ISOTROPIC_3D_MANTLE) 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
- 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
- allocate(rmass_ocean_load(nglob_oceans),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate rmass_ocean_load in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- endif
-
-! save the binary files
-!! DK DK MERGED UGLY this is the only thing we are going to have to save
-! call save_arrays_solver(rho_vp,rho_vs,nspec_stacey, &
-! prname,iregion_code,xixstore,xiystore,xizstore, &
-! etaxstore,etaystore,etazstore, &
-! gammaxstore,gammaystore,gammazstore, &
-! xstore,ystore,zstore, rhostore, &
-! kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
-! nspec_ani, &
-! c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
-! c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
-! c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
-! ibool,idoubling,rmass,rmass_ocean_load,nglob_oceans, &
-! ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
-! nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
-! normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
-! jacobian2D_xmin,jacobian2D_xmax, &
-! jacobian2D_ymin,jacobian2D_ymax, &
-! jacobian2D_bottom,jacobian2D_top, &
-! nspec,nglob, &
-! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
-! TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS, &
-! tau_s,tau_e_store,Qmu_store,T_c_source, &
-! ATTENUATION,ATTENUATION_3D, &
-! size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5),&
-! NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NEX_XI,ichunk,NCHUNKS,ABSORBING_CONDITIONS,AM_V)
-
-! boundary mesh
- if (SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
-! first check the number of surface elements are the same for Moho, 400, 670
- if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
- if (ispec2D_moho_top /= NSPEC2D_MOHO .or. ispec2D_moho_bot /= NSPEC2D_MOHO) &
- call exit_mpi(myrank, 'Not the same number of Moho surface elements')
- endif
- if (ispec2D_400_top /= NSPEC2D_400 .or. ispec2D_400_bot /= NSPEC2D_400) &
- call exit_mpi(myrank,'Not the same number of 400 surface elements')
- if (ispec2D_670_top /= NSPEC2D_670 .or. ispec2D_670_bot /= NSPEC2D_670) &
- call exit_mpi(myrank,'Not the same number of 670 surface elements')
-
-! writing surface topology databases
- open(unit=27,file=prname(1:len_trim(prname))//'boundary_disc.bin',status='unknown',form='unformatted')
- write(27) NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670
- write(27) ibelm_moho_top
- write(27) ibelm_moho_bot
- write(27) ibelm_400_top
- write(27) ibelm_400_bot
- write(27) ibelm_670_top
- write(27) ibelm_670_bot
- write(27) normal_moho
- write(27) normal_400
- write(27) normal_670
- close(27)
-
- deallocate(ibelm_moho_top,ibelm_moho_bot,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate ibelm_moho_top in create_regions_mesh ier=",ier
- endif
-
- deallocate(ibelm_400_top,ibelm_400_bot,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate ibelm_400_top in create_regions_mesh ier=",ier
- endif
-
- deallocate(ibelm_670_top,ibelm_670_bot,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate ibelm_670_top,ibelm_670_bot in create_regions_mesh ier=",ier
- endif
-
- deallocate(normal_moho,normal_400,normal_670,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate normal_moho,normal_400,normal_670 in create_regions_mesh ier=",ier
- endif
-
- deallocate(jacobian2D_moho,jacobian2D_400,jacobian2D_670,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate jacobian2D_moho,jacobian2D_400,jacobian2D_670 in create_regions_mesh ier=",ier
- endif
-
- endif
-
-! 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 for 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 for 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
-
-! deallocate arrays
- deallocate(rhostore_local,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate rhostore_local in create_regions_mesh ier=",ier
- endif
-
- deallocate(kappavstore_local,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate kappavstore_local in create_regions_mesh ier=",ier
- endif
-
-
- deallocate(c11store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c11store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c12store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c12store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c13store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c13store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c14store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c14store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c15store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c15store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c16store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c16store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c22store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c22store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c23store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c23store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c24store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c24store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c25store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c25store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c26store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c26store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c33store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c33store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c34store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c34store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c35store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c35store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c36store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c36store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c44store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c44store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c45store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c45store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c46store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c46store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c55store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c55store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c56store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c56store in create_regions_mesh ier=",ier
- endif
-
- deallocate(c66store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate c66store in create_regions_mesh ier=",ier
- endif
-
-
- deallocate(iboun,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate iboun in create_regions_mesh ier=",ier
- endif
-
- deallocate(xigll,yigll,zigll,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate xigll,yigll,zigll in create_regions_mesh ier=",ier
- endif
-
- deallocate(wxgll,wygll,wzgll,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate wxgll,wygll,wzgll in create_regions_mesh ier=",ier
- endif
-
- deallocate(shape3D,dershape3D,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate shape3D,dershape3D in create_regions_mesh ier=",ier
- endif
-
- deallocate(shape2D_x,shape2D_y,shape2D_bottom,shape2D_top,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate shape2D_x,shape2D_y,shape2D_bottom,shape2D_top in create_regions_mesh ier=",ier
- endif
-
- deallocate(dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top" &
- ," in create_regions_mesh ier=",ier
- endif
-
- deallocate(iMPIcut_xi,iMPIcut_eta,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate iMPIcut_xi,iMPIcut_eta in create_regions_mesh ier=",ier
- endif
-
-
- deallocate(nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta ",&
- "in create_regions_mesh ier=",ier
- endif
-
- deallocate(rho_vp,rho_vs,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate rho_vp,rho_vs in create_regions_mesh ier=",ier
- endif
-
-
- deallocate(Qmu_store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate Qmu_store in create_regions_mesh ier=",ier
- endif
-
- deallocate(tau_e_store,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate tau_e_store in create_regions_mesh ier=",ier
- endif
-
- if (allocated(rmass_ocean_load) ) then
- deallocate(rmass_ocean_load,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate rmass_ocean_load in create_regions_mesh ier=",ier
- endif
- endif
-
-
- end subroutine create_regions_mesh
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/crustal_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/crustal_model.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/crustal_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,367 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-!
-! read and smooth crust2.0 model
-! based on software routines provided with the crust2.0 model by Bassin et al.
-!
-
- subroutine crustal_model(lat,lon,x,vp,vs,rho,moho,found_crust,CM_V)
-
- implicit none
- include "constants.h"
-
-! 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
-
- double precision lat,lon,x,vp,vs,rho,moho
- logical found_crust
-
- double precision h_sed,h_uc
- double precision x3,x4,x5,x6,x7,scaleval
- double precision vps(NLAYERS_CRUST),vss(NLAYERS_CRUST),rhos(NLAYERS_CRUST),thicks(NLAYERS_CRUST)
-
- call crust(lat,lon,vps,vss,rhos,thicks,CM_V%abbreviation,CM_V%code,CM_V%thlr,CM_V%velocp,CM_V%velocs,CM_V%dens)
-
- x3 = (R_EARTH-thicks(3)*1000.0d0)/R_EARTH
- h_sed = thicks(3) + thicks(4)
- x4 = (R_EARTH-h_sed*1000.0d0)/R_EARTH
- h_uc = h_sed + thicks(5)
- x5 = (R_EARTH-h_uc*1000.0d0)/R_EARTH
- x6 = (R_EARTH-(h_uc+thicks(6))*1000.0d0)/R_EARTH
- x7 = (R_EARTH-(h_uc+thicks(6)+thicks(7))*1000.0d0)/R_EARTH
-
- found_crust = .true.
- if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST) then
- vp = vps(3)
- vs = vss(3)
- rho = rhos(3)
- else if(x > x4 .and. INCLUDE_SEDIMENTS_CRUST) then
- vp = vps(4)
- vs = vss(4)
- rho = rhos(4)
- else if(x > x5) then
- vp = vps(5)
- vs = vss(5)
- rho = rhos(5)
- else if(x > x6) then
- vp = vps(6)
- vs = vss(6)
- rho = rhos(6)
- else if(x > x7) then
- vp = vps(7)
- vs = vss(7)
- rho = rhos(7)
- else
- found_crust = .false.
- endif
-
- if (found_crust) then
-! non-dimensionalize
- scaleval = dsqrt(PI*GRAV*RHOAV)
- vp = vp*1000.0d0/(R_EARTH*scaleval)
- vs = vs*1000.0d0/(R_EARTH*scaleval)
- rho = rho*1000.0d0/RHOAV
- moho = (h_uc+thicks(6)+thicks(7))*1000.0d0/R_EARTH
- endif
-
- end subroutine crustal_model
-
-!---------------------------
-
- subroutine read_crustal_model(CM_V)
-
- implicit none
- include "constants.h"
-
-! 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
-
-! local variables
- integer i
- integer ila,icolat
- integer ikey
-
- double precision h_moho_min,h_moho_max
-
- character(len=150) CNtype2, CNtype2_key_modif
-
- call get_value_string(CNtype2, 'model.CNtype2', 'DATA/crust2.0/CNtype2.txt')
- call get_value_string(CNtype2_key_modif, 'model.CNtype2_key_modif', 'DATA/crust2.0/CNtype2_key_modif.txt')
-
- open(unit=1,file=CNtype2,status='old',action='read')
- do ila=1,NCAP_CRUST/2
- read(1,*) icolat,(CM_V%abbreviation(ila,i),i=1,NCAP_CRUST)
- enddo
- close(1)
-
- open(unit=1,file=CNtype2_key_modif,status='old',action='read')
- h_moho_min=HUGEVAL
- h_moho_max=-HUGEVAL
- do ikey=1,NKEYS_CRUST
- read (1,"(a2)") CM_V%code(ikey)
- read (1,*) (CM_V%velocp(ikey,i),i=1,NLAYERS_CRUST)
- read (1,*) (CM_V%velocs(ikey,i),i=1,NLAYERS_CRUST)
- read (1,*) (CM_V%dens(ikey,i),i=1,NLAYERS_CRUST)
- read (1,*) (CM_V%thlr(ikey,i),i=1,NLAYERS_CRUST-1),CM_V%thlr(ikey,NLAYERS_CRUST)
- if(CM_V%thlr(ikey,NLAYERS_CRUST) > h_moho_max) h_moho_max=CM_V%thlr(ikey,NLAYERS_CRUST)
- if(CM_V%thlr(ikey,NLAYERS_CRUST) < h_moho_min) h_moho_min=CM_V%thlr(ikey,NLAYERS_CRUST)
- enddo
- close(1)
-
- if(h_moho_min == HUGEVAL .or. h_moho_max == -HUGEVAL) &
- stop 'incorrect moho depths in read_3D_crustal_model'
-
- end subroutine read_crustal_model
-
-!---------------------------
-
- subroutine crust(lat,lon,velp,vels,rho,thick,abbreviation,code,thlr,velocp,velocs,dens)
-
-! crustal vp and vs in km/s, layer thickness in km
-! crust2.0 is smoothed with a cap of size CAP using NTHETA points
-! in the theta direction and NPHI in the phi direction.
-! The cap is rotated to the North Pole.
-
- implicit none
- include "constants.h"
-
- integer, parameter :: NTHETA = 2
- integer, parameter :: NPHI = 10
- double precision, parameter :: CAP = 2.0d0*PI/180.0d0
-
-! argument variables
- double precision lat,lon
- double precision rho(NLAYERS_CRUST),thick(NLAYERS_CRUST),velp(NLAYERS_CRUST),vels(NLAYERS_CRUST)
- double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
- double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
- character(len=2) code(NKEYS_CRUST),abbreviation(NCAP_CRUST/2,NCAP_CRUST)
-
-! local variables
- integer i,j,k,icolat,ilon,ierr
- integer itheta,iphi,npoints
- double precision theta,phi,sint,cost,sinp,cosp,dtheta,dphi,cap_area,wght,total
- double precision r_rot,theta_rot,phi_rot
- double precision rotation_matrix(3,3),x(3),xc(3)
- double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
- double precision rhol(NLAYERS_CRUST),thickl(NLAYERS_CRUST),velpl(NLAYERS_CRUST),velsl(NLAYERS_CRUST)
- character(len=2) crustaltype
-
-! get integer colatitude and longitude of crustal cap
-! -90<lat<90 -180<lon<180
- if(lat > 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) &
- stop 'error in latitude/longitude range in crust'
- if(lat==90.0d0) lat=89.9999d0
- if(lat==-90.0d0) lat=-89.9999d0
- if(lon==180.0d0) lon=179.9999d0
- if(lon==-180.0d0) lon=-179.9999d0
-
- call icolat_ilon(lat,lon,icolat,ilon)
- crustaltype=abbreviation(icolat,ilon)
- call get_crust_structure(crustaltype,velp,vels,rho,thick, &
- code,thlr,velocp,velocs,dens,ierr)
-
-! uncomment the following line to use crust2.0 as is, without smoothing
-!
-! return
-
- theta = (90.0-lat)*PI/180.0
- phi = lon*PI/180.0
-
- sint = sin(theta)
- cost = cos(theta)
- sinp = sin(phi)
- cosp = cos(phi)
-
-! set up rotation matrix to go from cap at North pole
-! to cap around point of interest
- rotation_matrix(1,1) = cosp*cost
- rotation_matrix(1,2) = -sinp
- rotation_matrix(1,3) = cosp*sint
- rotation_matrix(2,1) = sinp*cost
- rotation_matrix(2,2) = cosp
- rotation_matrix(2,3) = sinp*sint
- rotation_matrix(3,1) = -sint
- rotation_matrix(3,2) = 0.0
- rotation_matrix(3,3) = cost
-
- dtheta = CAP/dble(NTHETA)
- dphi = 2.0*PI/dble(NPHI)
- cap_area = 2.0*PI*(1.0-cos(CAP))
-
-! integrate over a cap at the North pole
- i = 0
- total = 0.0
- do itheta = 1,NTHETA
-
- theta = 0.5*dble(2*itheta-1)*CAP/dble(NTHETA)
- cost = cos(theta)
- sint = sin(theta)
- wght = sint*dtheta*dphi/cap_area
-
- do iphi = 1,NPHI
-
- i = i+1
-! get the weight associated with this integration point (same for all phi)
- weight(i) = wght
- total = total + weight(i)
- phi = dble(2*iphi-1)*PI/dble(NPHI)
- cosp = cos(phi)
- sinp = sin(phi)
-! x,y,z coordinates of integration point in cap at North pole
- xc(1) = sint*cosp
- xc(2) = sint*sinp
- xc(3) = cost
-! get x,y,z coordinates in cap around point of interest
- do j=1,3
- x(j) = 0.0
- do k=1,3
- x(j) = x(j)+rotation_matrix(j,k)*xc(k)
- enddo
- enddo
-! get latitude and longitude (degrees) of integration point
- call xyz_2_rthetaphi_dble(x(1),x(2),x(3),r_rot,theta_rot,phi_rot)
- call reduce(theta_rot,phi_rot)
- xlat(i) = (PI/2.0-theta_rot)*180.0/PI
- xlon(i) = phi_rot*180.0/PI
- if(xlon(i) > 180.0) xlon(i) = xlon(i)-360.0
-
- enddo
-
- enddo
-
- if(abs(total-1.0) > 0.001) stop 'error in cap integration for crust2.0'
-
- npoints = i
-
- do j=1,NLAYERS_CRUST
- rho(j)=0.0d0
- thick(j)=0.0d0
- velp(j)=0.0d0
- vels(j)=0.0d0
- enddo
-
- do i=1,npoints
- call icolat_ilon(xlat(i),xlon(i),icolat,ilon)
- crustaltype=abbreviation(icolat,ilon)
- call get_crust_structure(crustaltype,velpl,velsl,rhol,thickl, &
- code,thlr,velocp,velocs,dens,ierr)
- if(ierr /= 0) stop 'error in routine get_crust_structure'
- do j=1,NLAYERS_CRUST
- rho(j)=rho(j)+weight(i)*rhol(j)
- thick(j)=thick(j)+weight(i)*thickl(j)
- velp(j)=velp(j)+weight(i)*velpl(j)
- vels(j)=vels(j)+weight(i)*velsl(j)
- enddo
- enddo
-
- end subroutine crust
-
-!------------------------------------------------------
-
- subroutine icolat_ilon(xlat,xlon,icolat,ilon)
-
- implicit none
-
-
-! argument variables
- double precision xlat,xlon
- integer icolat,ilon
-
- if(xlat > 90.0d0 .or. xlat < -90.0d0 .or. xlon > 180.0d0 .or. xlon < -180.0d0) &
- stop 'error in latitude/longitude range in icolat_ilon'
- icolat=int(1+((90.d0-xlat)/2.d0))
- if(icolat == 91) icolat=90
- ilon=int(1+((180.d0+xlon)/2.d0))
- if(ilon == 181) ilon=1
-
- if(icolat>90 .or. icolat<1) stop 'error in routine icolat_ilon'
- if(ilon<1 .or. ilon>180) stop 'error in routine icolat_ilon'
-
- end subroutine icolat_ilon
-
-!---------------------------------------------------------------------
-
- subroutine get_crust_structure(type,vptyp,vstyp,rhtyp,thtp, &
- code,thlr,velocp,velocs,dens,ierr)
-
- implicit none
- include "constants.h"
-
-
-! argument variables
- integer ierr
- double precision rhtyp(NLAYERS_CRUST),thtp(NLAYERS_CRUST)
- double precision vptyp(NLAYERS_CRUST),vstyp(NLAYERS_CRUST)
- character(len=2) type,code(NKEYS_CRUST)
- double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
- double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
-
-! local variables
- integer i,ikey
-
- ierr=1
- do ikey=1,NKEYS_CRUST
- if (code(ikey) == type) then
- do i=1,NLAYERS_CRUST
- vptyp(i)=velocp(ikey,i)
- vstyp(i)=velocs(ikey,i)
- rhtyp(i)=dens(ikey,i)
- enddo
- do i=1,NLAYERS_CRUST-1
- thtp(i)=thlr(ikey,i)
- enddo
-! get distance to Moho from the bottom of the ocean or the ice
- thtp(NLAYERS_CRUST)=thlr(ikey,NLAYERS_CRUST)-thtp(1)-thtp(2)
- ierr=0
- endif
- enddo
-
- end subroutine get_crust_structure
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/deallocate.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/deallocate.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/deallocate.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,275 +0,0 @@
-
-!! DK DK this for the new merged version
-
- deallocate(xstore_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(ystore_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(zstore_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
- deallocate(xstore_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(ystore_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(zstore_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
- deallocate(xstore_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(ystore_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(zstore_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
-!---
-
- deallocate(xix_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(xiy_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(xiz_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(etax_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(etay_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(etaz_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(gammax_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(gammay_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(gammaz_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
- deallocate(xix_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(xiy_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(xiz_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(etax_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(etay_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(etaz_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(gammax_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(gammay_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(gammaz_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
- deallocate(xix_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(xiy_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(xiz_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(etax_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(etay_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(etaz_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(gammax_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(gammay_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(gammaz_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
- deallocate(rmass_ocean_load,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
-!---
-
- deallocate(displ_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(veloc_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(accel_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
- deallocate(displ_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(veloc_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(accel_outer_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
- deallocate(displ_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(veloc_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
- deallocate(accel_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
-!---
-
- deallocate(R_memory_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
- deallocate(R_memory_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
-!---
-
- deallocate(epsilondev_crust_mantle,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
- deallocate(epsilondev_inner_core,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
- endif
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/declar.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/declar.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/declar.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,174 +0,0 @@
-
-!! DK DK added this temporarily
-!!!!!!!!!!!!! integer, dimension(NSPEC_CRUST_MANTLE) :: perm,invperm
-!! DK DK suppressed for now because useless when CUTHILL-MCKEE is off
- integer, dimension(1) :: perm,invperm
-
-!! 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(:,:), 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
-
- real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:,:) :: R_memory_crust_mantle
- real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:) :: epsilondev_crust_mantle
- real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:,:) :: R_memory_inner_core
- real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:) :: epsilondev_inner_core
- real(kind=CUSTOM_REAL), allocatable, dimension(:) :: rmass_ocean_load
- real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:) :: &
- 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), allocatable, dimension(:) :: xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
- real(kind=CUSTOM_REAL), allocatable, dimension(:,:) :: &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
- real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:) :: &
- 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), allocatable, dimension(:) :: xstore_outer_core,ystore_outer_core,zstore_outer_core
- real(kind=CUSTOM_REAL), allocatable, dimension(:) :: displ_outer_core,veloc_outer_core,accel_outer_core
- real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:) :: &
- 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
-
- real(kind=CUSTOM_REAL), allocatable, dimension(:) :: xstore_inner_core,ystore_inner_core,zstore_inner_core
- real(kind=CUSTOM_REAL), allocatable, dimension(:,:) :: displ_inner_core,veloc_inner_core,accel_inner_core
-
-!!!!!!!!!!!!!!!! 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
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_CM) :: &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(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
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_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
-
- real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL_CM) :: buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB1D_RADIAL_CM + NGLOB1D_RADIAL_IC) :: &
- buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector
-
- 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
-
- 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), 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_derivation_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_derivation_matrices.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_derivation_matrices.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,178 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 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)
-
- implicit none
-
- include "constants.h"
-
-! 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
-
-! 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
-
-! array with all the weights in the cube
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
-
-! function for calculating derivatives of Lagrange polynomials
- double precision, external :: lagrange_deriv_GLL
-
- integer i,j,k,i1,i2,j1,j2,k1,k2
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! 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
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
-
-! calculate derivatives of the Lagrange polynomials
-! and precalculate some products in double precision
-! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
- do i1=1,NGLLX
- do i2=1,NGLLX
- hprime_xx(i2,i1) = sngl(lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX))
- hprimewgll_xx(i2,i1) = sngl(lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)*wxgll(i2))
- enddo
- enddo
-
- do j1=1,NGLLY
- do j2=1,NGLLY
- hprime_yy(j2,j1) = sngl(lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY))
- hprimewgll_yy(j2,j1) = sngl(lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)*wygll(j2))
- enddo
- enddo
-
- do k1=1,NGLLZ
- do k2=1,NGLLZ
- hprime_zz(k2,k1) = sngl(lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ))
- hprimewgll_zz(k2,k1) = sngl(lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)*wzgll(k2))
- enddo
- enddo
-
- do i=1,NGLLX
- do j=1,NGLLY
- wgllwgll_xy(i,j) = sngl(wxgll(i)*wygll(j))
- enddo
- enddo
-
- do i=1,NGLLX
- do k=1,NGLLZ
- wgllwgll_xz(i,k) = sngl(wxgll(i)*wzgll(k))
- enddo
- enddo
-
- do j=1,NGLLY
- do k=1,NGLLZ
- wgllwgll_yz(j,k) = sngl(wygll(j)*wzgll(k))
- enddo
- enddo
-
- do i=1,NGLLX
- do j=1,NGLLY
- do k=1,NGLLZ
- wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
- enddo
- enddo
- enddo
-
- else ! double precision version
-
-! calculate derivatives of the Lagrange polynomials
-! and precalculate some products in double precision
-! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
- do i1=1,NGLLX
- do i2=1,NGLLX
- hprime_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)
- hprimewgll_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)*wxgll(i2)
- enddo
- enddo
-
- do j1=1,NGLLY
- do j2=1,NGLLY
- hprime_yy(j2,j1) = lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)
- hprimewgll_yy(j2,j1) = lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)*wygll(j2)
- enddo
- enddo
-
- do k1=1,NGLLZ
- do k2=1,NGLLZ
- hprime_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)
- hprimewgll_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)*wzgll(k2)
- enddo
- enddo
-
- do i=1,NGLLX
- do j=1,NGLLY
- wgllwgll_xy(i,j) = wxgll(i)*wygll(j)
- enddo
- enddo
-
- do i=1,NGLLX
- do k=1,NGLLZ
- wgllwgll_xz(i,k) = wxgll(i)*wzgll(k)
- enddo
- enddo
-
- do j=1,NGLLY
- do k=1,NGLLZ
- wgllwgll_yz(j,k) = wygll(j)*wzgll(k)
- enddo
- enddo
-
- do i=1,NGLLX
- do j=1,NGLLY
- do k=1,NGLLZ
- wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
- enddo
- enddo
- enddo
-
- endif
-
- end subroutine define_derivation_matrices
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_superbrick.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_superbrick.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_superbrick.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,2036 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! define the superbrick that implements the symmetric four-to-two mesh doubling.
-! Generated automatically by a script: UTILS/doubling_brick/define_superbrick.pl
-
- subroutine define_superbrick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
-
- implicit none
-
- include "constants.h"
-
- integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
- double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
- logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
-
- x_superbrick(1) = 3.d0 / 2.d0
- y_superbrick(1) = 1.d0
- z_superbrick(1) = 2.d0
-
- x_superbrick(2) = 3.d0 / 2.d0
- y_superbrick(2) = 1.d0
- z_superbrick(2) = 3.d0 / 2.d0
-
- x_superbrick(3) = 3.d0 / 2.d0
- y_superbrick(3) = 3.d0 / 2.d0
- z_superbrick(3) = 3.d0 / 2.d0
-
- x_superbrick(4) = 3.d0 / 2.d0
- y_superbrick(4) = 3.d0 / 2.d0
- z_superbrick(4) = 2.d0
-
- x_superbrick(5) = 2.d0
- y_superbrick(5) = 1.d0
- z_superbrick(5) = 2.d0
-
- x_superbrick(6) = 2.d0
- y_superbrick(6) = 1.d0
- z_superbrick(6) = 1.d0
-
- x_superbrick(7) = 2.d0
- y_superbrick(7) = 3.d0 / 2.d0
- z_superbrick(7) = 1.d0
-
- x_superbrick(8) = 2.d0
- y_superbrick(8) = 3.d0 / 2.d0
- z_superbrick(8) = 2.d0
-
- x_superbrick(9) = 3.d0 / 2.d0
- y_superbrick(9) = 2.d0
- z_superbrick(9) = 1.d0
-
- x_superbrick(10) = 3.d0 / 2.d0
- y_superbrick(10) = 2.d0
- z_superbrick(10) = 2.d0
-
- x_superbrick(11) = 2.d0
- y_superbrick(11) = 2.d0
- z_superbrick(11) = 1.d0 / 2.d0
-
- x_superbrick(12) = 2.d0
- y_superbrick(12) = 2.d0
- z_superbrick(12) = 2.d0
-
- x_superbrick(13) = 1.d0
- y_superbrick(13) = 1.d0
- z_superbrick(13) = 1.d0
-
- x_superbrick(14) = 1.d0
- y_superbrick(14) = 1.d0
- z_superbrick(14) = 1.d0 / 2.d0
-
- x_superbrick(15) = 1.d0
- y_superbrick(15) = 2.d0
- z_superbrick(15) = 1.d0 / 2.d0
-
- x_superbrick(16) = 1.d0
- y_superbrick(16) = 2.d0
- z_superbrick(16) = 1.d0
-
- x_superbrick(17) = 3.d0 / 2.d0
- y_superbrick(17) = 1.d0
- z_superbrick(17) = 1.d0
-
- x_superbrick(18) = 2.d0
- y_superbrick(18) = 1.d0
- z_superbrick(18) = 1.d0 / 2.d0
-
- x_superbrick(19) = 1.d0
- y_superbrick(19) = 1.d0
- z_superbrick(19) = 3.d0 / 2.d0
-
- x_superbrick(20) = 1.d0
- y_superbrick(20) = 1.d0
- z_superbrick(20) = 2.d0
-
- x_superbrick(21) = 1.d0
- y_superbrick(21) = 3.d0 / 2.d0
- z_superbrick(21) = 3.d0 / 2.d0
-
- x_superbrick(22) = 1.d0
- y_superbrick(22) = 3.d0 / 2.d0
- z_superbrick(22) = 2.d0
-
- x_superbrick(23) = 1.d0
- y_superbrick(23) = 2.d0
- z_superbrick(23) = 2.d0
-
- x_superbrick(24) = 1.d0
- y_superbrick(24) = 1.d0
- z_superbrick(24) = 0.d0
-
- x_superbrick(25) = 2.d0
- y_superbrick(25) = 1.d0
- z_superbrick(25) = 0.d0
-
- x_superbrick(26) = 2.d0
- y_superbrick(26) = 2.d0
- z_superbrick(26) = 0.d0
-
- x_superbrick(27) = 1.d0
- y_superbrick(27) = 2.d0
- z_superbrick(27) = 0.d0
-
- x_superbrick(28) = 3.d0 / 2.d0
- y_superbrick(28) = 1.d0 / 2.d0
- z_superbrick(28) = 3.d0 / 2.d0
-
- x_superbrick(29) = 3.d0 / 2.d0
- y_superbrick(29) = 1.d0 / 2.d0
- z_superbrick(29) = 2.d0
-
- x_superbrick(30) = 2.d0
- y_superbrick(30) = 1.d0 / 2.d0
- z_superbrick(30) = 1.d0
-
- x_superbrick(31) = 2.d0
- y_superbrick(31) = 1.d0 / 2.d0
- z_superbrick(31) = 2.d0
-
- x_superbrick(32) = 3.d0 / 2.d0
- y_superbrick(32) = 0.d0
- z_superbrick(32) = 1.d0
-
- x_superbrick(33) = 3.d0 / 2.d0
- y_superbrick(33) = 0.d0
- z_superbrick(33) = 2.d0
-
- x_superbrick(34) = 2.d0
- y_superbrick(34) = 0.d0
- z_superbrick(34) = 1.d0 / 2.d0
-
- x_superbrick(35) = 2.d0
- y_superbrick(35) = 0.d0
- z_superbrick(35) = 2.d0
-
- x_superbrick(36) = 1.d0
- y_superbrick(36) = 0.d0
- z_superbrick(36) = 1.d0 / 2.d0
-
- x_superbrick(37) = 1.d0
- y_superbrick(37) = 0.d0
- z_superbrick(37) = 1.d0
-
- x_superbrick(38) = 1.d0
- y_superbrick(38) = 1.d0 / 2.d0
- z_superbrick(38) = 3.d0 / 2.d0
-
- x_superbrick(39) = 1.d0
- y_superbrick(39) = 1.d0 / 2.d0
- z_superbrick(39) = 2.d0
-
- x_superbrick(40) = 1.d0
- y_superbrick(40) = 0.d0
- z_superbrick(40) = 2.d0
-
- x_superbrick(41) = 2.d0
- y_superbrick(41) = 0.d0
- z_superbrick(41) = 0.d0
-
- x_superbrick(42) = 1.d0
- y_superbrick(42) = 0.d0
- z_superbrick(42) = 0.d0
-
- x_superbrick(43) = 1.d0 / 2.d0
- y_superbrick(43) = 1.d0
- z_superbrick(43) = 2.d0
-
- x_superbrick(44) = 1.d0 / 2.d0
- y_superbrick(44) = 1.d0
- z_superbrick(44) = 3.d0 / 2.d0
-
- x_superbrick(45) = 1.d0 / 2.d0
- y_superbrick(45) = 3.d0 / 2.d0
- z_superbrick(45) = 3.d0 / 2.d0
-
- x_superbrick(46) = 1.d0 / 2.d0
- y_superbrick(46) = 3.d0 / 2.d0
- z_superbrick(46) = 2.d0
-
- x_superbrick(47) = 0.d0
- y_superbrick(47) = 1.d0
- z_superbrick(47) = 2.d0
-
- x_superbrick(48) = 0.d0
- y_superbrick(48) = 1.d0
- z_superbrick(48) = 1.d0
-
- x_superbrick(49) = 0.d0
- y_superbrick(49) = 3.d0 / 2.d0
- z_superbrick(49) = 1.d0
-
- x_superbrick(50) = 0.d0
- y_superbrick(50) = 3.d0 / 2.d0
- z_superbrick(50) = 2.d0
-
- x_superbrick(51) = 1.d0 / 2.d0
- y_superbrick(51) = 2.d0
- z_superbrick(51) = 1.d0
-
- x_superbrick(52) = 1.d0 / 2.d0
- y_superbrick(52) = 2.d0
- z_superbrick(52) = 2.d0
-
- x_superbrick(53) = 0.d0
- y_superbrick(53) = 2.d0
- z_superbrick(53) = 1.d0 / 2.d0
-
- x_superbrick(54) = 0.d0
- y_superbrick(54) = 2.d0
- z_superbrick(54) = 2.d0
-
- x_superbrick(55) = 1.d0 / 2.d0
- y_superbrick(55) = 1.d0
- z_superbrick(55) = 1.d0
-
- x_superbrick(56) = 0.d0
- y_superbrick(56) = 1.d0
- z_superbrick(56) = 1.d0 / 2.d0
-
- x_superbrick(57) = 0.d0
- y_superbrick(57) = 1.d0
- z_superbrick(57) = 0.d0
-
- x_superbrick(58) = 0.d0
- y_superbrick(58) = 2.d0
- z_superbrick(58) = 0.d0
-
- x_superbrick(59) = 1.d0 / 2.d0
- y_superbrick(59) = 1.d0 / 2.d0
- z_superbrick(59) = 3.d0 / 2.d0
-
- x_superbrick(60) = 1.d0 / 2.d0
- y_superbrick(60) = 1.d0 / 2.d0
- z_superbrick(60) = 2.d0
-
- x_superbrick(61) = 0.d0
- y_superbrick(61) = 1.d0 / 2.d0
- z_superbrick(61) = 1.d0
-
- x_superbrick(62) = 0.d0
- y_superbrick(62) = 1.d0 / 2.d0
- z_superbrick(62) = 2.d0
-
- x_superbrick(63) = 1.d0 / 2.d0
- y_superbrick(63) = 0.d0
- z_superbrick(63) = 1.d0
-
- x_superbrick(64) = 1.d0 / 2.d0
- y_superbrick(64) = 0.d0
- z_superbrick(64) = 2.d0
-
- x_superbrick(65) = 0.d0
- y_superbrick(65) = 0.d0
- z_superbrick(65) = 1.d0 / 2.d0
-
- x_superbrick(66) = 0.d0
- y_superbrick(66) = 0.d0
- z_superbrick(66) = 2.d0
-
- x_superbrick(67) = 0.d0
- y_superbrick(67) = 0.d0
- z_superbrick(67) = 0.d0
-
- ibool_superbrick(1, 1) = 2
- ibool_superbrick(2, 1) = 6
- ibool_superbrick(3, 1) = 7
- ibool_superbrick(4, 1) = 3
- ibool_superbrick(5, 1) = 1
- ibool_superbrick(6, 1) = 5
- ibool_superbrick(7, 1) = 8
- ibool_superbrick(8, 1) = 4
-
- ibool_superbrick(1, 2) = 3
- ibool_superbrick(2, 2) = 7
- ibool_superbrick(3, 2) = 11
- ibool_superbrick(4, 2) = 9
- ibool_superbrick(5, 2) = 4
- ibool_superbrick(6, 2) = 8
- ibool_superbrick(7, 2) = 12
- ibool_superbrick(8, 2) = 10
-
- ibool_superbrick(1, 3) = 14
- ibool_superbrick(2, 3) = 18
- ibool_superbrick(3, 3) = 11
- ibool_superbrick(4, 3) = 15
- ibool_superbrick(5, 3) = 13
- ibool_superbrick(6, 3) = 17
- ibool_superbrick(7, 3) = 9
- ibool_superbrick(8, 3) = 16
-
- ibool_superbrick(1, 4) = 19
- ibool_superbrick(2, 4) = 2
- ibool_superbrick(3, 4) = 3
- ibool_superbrick(4, 4) = 21
- ibool_superbrick(5, 4) = 20
- ibool_superbrick(6, 4) = 1
- ibool_superbrick(7, 4) = 4
- ibool_superbrick(8, 4) = 22
-
- ibool_superbrick(1, 5) = 17
- ibool_superbrick(2, 5) = 18
- ibool_superbrick(3, 5) = 11
- ibool_superbrick(4, 5) = 9
- ibool_superbrick(5, 5) = 2
- ibool_superbrick(6, 5) = 6
- ibool_superbrick(7, 5) = 7
- ibool_superbrick(8, 5) = 3
-
- ibool_superbrick(1, 6) = 21
- ibool_superbrick(2, 6) = 3
- ibool_superbrick(3, 6) = 9
- ibool_superbrick(4, 6) = 16
- ibool_superbrick(5, 6) = 22
- ibool_superbrick(6, 6) = 4
- ibool_superbrick(7, 6) = 10
- ibool_superbrick(8, 6) = 23
-
- ibool_superbrick(1, 7) = 13
- ibool_superbrick(2, 7) = 17
- ibool_superbrick(3, 7) = 9
- ibool_superbrick(4, 7) = 16
- ibool_superbrick(5, 7) = 19
- ibool_superbrick(6, 7) = 2
- ibool_superbrick(7, 7) = 3
- ibool_superbrick(8, 7) = 21
-
- ibool_superbrick(1, 8) = 24
- ibool_superbrick(2, 8) = 25
- ibool_superbrick(3, 8) = 26
- ibool_superbrick(4, 8) = 27
- ibool_superbrick(5, 8) = 14
- ibool_superbrick(6, 8) = 18
- ibool_superbrick(7, 8) = 11
- ibool_superbrick(8, 8) = 15
-
- ibool_superbrick(1, 9) = 28
- ibool_superbrick(2, 9) = 30
- ibool_superbrick(3, 9) = 6
- ibool_superbrick(4, 9) = 2
- ibool_superbrick(5, 9) = 29
- ibool_superbrick(6, 9) = 31
- ibool_superbrick(7, 9) = 5
- ibool_superbrick(8, 9) = 1
-
- ibool_superbrick(1, 10) = 32
- ibool_superbrick(2, 10) = 34
- ibool_superbrick(3, 10) = 30
- ibool_superbrick(4, 10) = 28
- ibool_superbrick(5, 10) = 33
- ibool_superbrick(6, 10) = 35
- ibool_superbrick(7, 10) = 31
- ibool_superbrick(8, 10) = 29
-
- ibool_superbrick(1, 11) = 36
- ibool_superbrick(2, 11) = 34
- ibool_superbrick(3, 11) = 18
- ibool_superbrick(4, 11) = 14
- ibool_superbrick(5, 11) = 37
- ibool_superbrick(6, 11) = 32
- ibool_superbrick(7, 11) = 17
- ibool_superbrick(8, 11) = 13
-
- ibool_superbrick(1, 12) = 38
- ibool_superbrick(2, 12) = 28
- ibool_superbrick(3, 12) = 2
- ibool_superbrick(4, 12) = 19
- ibool_superbrick(5, 12) = 39
- ibool_superbrick(6, 12) = 29
- ibool_superbrick(7, 12) = 1
- ibool_superbrick(8, 12) = 20
-
- ibool_superbrick(1, 13) = 32
- ibool_superbrick(2, 13) = 34
- ibool_superbrick(3, 13) = 18
- ibool_superbrick(4, 13) = 17
- ibool_superbrick(5, 13) = 28
- ibool_superbrick(6, 13) = 30
- ibool_superbrick(7, 13) = 6
- ibool_superbrick(8, 13) = 2
-
- ibool_superbrick(1, 14) = 37
- ibool_superbrick(2, 14) = 32
- ibool_superbrick(3, 14) = 28
- ibool_superbrick(4, 14) = 38
- ibool_superbrick(5, 14) = 40
- ibool_superbrick(6, 14) = 33
- ibool_superbrick(7, 14) = 29
- ibool_superbrick(8, 14) = 39
-
- ibool_superbrick(1, 15) = 37
- ibool_superbrick(2, 15) = 32
- ibool_superbrick(3, 15) = 17
- ibool_superbrick(4, 15) = 13
- ibool_superbrick(5, 15) = 38
- ibool_superbrick(6, 15) = 28
- ibool_superbrick(7, 15) = 2
- ibool_superbrick(8, 15) = 19
-
- ibool_superbrick(1, 16) = 42
- ibool_superbrick(2, 16) = 41
- ibool_superbrick(3, 16) = 25
- ibool_superbrick(4, 16) = 24
- ibool_superbrick(5, 16) = 36
- ibool_superbrick(6, 16) = 34
- ibool_superbrick(7, 16) = 18
- ibool_superbrick(8, 16) = 14
-
- ibool_superbrick(1, 17) = 48
- ibool_superbrick(2, 17) = 44
- ibool_superbrick(3, 17) = 45
- ibool_superbrick(4, 17) = 49
- ibool_superbrick(5, 17) = 47
- ibool_superbrick(6, 17) = 43
- ibool_superbrick(7, 17) = 46
- ibool_superbrick(8, 17) = 50
-
- ibool_superbrick(1, 18) = 49
- ibool_superbrick(2, 18) = 45
- ibool_superbrick(3, 18) = 51
- ibool_superbrick(4, 18) = 53
- ibool_superbrick(5, 18) = 50
- ibool_superbrick(6, 18) = 46
- ibool_superbrick(7, 18) = 52
- ibool_superbrick(8, 18) = 54
-
- ibool_superbrick(1, 19) = 56
- ibool_superbrick(2, 19) = 14
- ibool_superbrick(3, 19) = 15
- ibool_superbrick(4, 19) = 53
- ibool_superbrick(5, 19) = 55
- ibool_superbrick(6, 19) = 13
- ibool_superbrick(7, 19) = 16
- ibool_superbrick(8, 19) = 51
-
- ibool_superbrick(1, 20) = 44
- ibool_superbrick(2, 20) = 19
- ibool_superbrick(3, 20) = 21
- ibool_superbrick(4, 20) = 45
- ibool_superbrick(5, 20) = 43
- ibool_superbrick(6, 20) = 20
- ibool_superbrick(7, 20) = 22
- ibool_superbrick(8, 20) = 46
-
- ibool_superbrick(1, 21) = 56
- ibool_superbrick(2, 21) = 55
- ibool_superbrick(3, 21) = 51
- ibool_superbrick(4, 21) = 53
- ibool_superbrick(5, 21) = 48
- ibool_superbrick(6, 21) = 44
- ibool_superbrick(7, 21) = 45
- ibool_superbrick(8, 21) = 49
-
- ibool_superbrick(1, 22) = 45
- ibool_superbrick(2, 22) = 21
- ibool_superbrick(3, 22) = 16
- ibool_superbrick(4, 22) = 51
- ibool_superbrick(5, 22) = 46
- ibool_superbrick(6, 22) = 22
- ibool_superbrick(7, 22) = 23
- ibool_superbrick(8, 22) = 52
-
- ibool_superbrick(1, 23) = 55
- ibool_superbrick(2, 23) = 13
- ibool_superbrick(3, 23) = 16
- ibool_superbrick(4, 23) = 51
- ibool_superbrick(5, 23) = 44
- ibool_superbrick(6, 23) = 19
- ibool_superbrick(7, 23) = 21
- ibool_superbrick(8, 23) = 45
-
- ibool_superbrick(1, 24) = 57
- ibool_superbrick(2, 24) = 24
- ibool_superbrick(3, 24) = 27
- ibool_superbrick(4, 24) = 58
- ibool_superbrick(5, 24) = 56
- ibool_superbrick(6, 24) = 14
- ibool_superbrick(7, 24) = 15
- ibool_superbrick(8, 24) = 53
-
- ibool_superbrick(1, 25) = 61
- ibool_superbrick(2, 25) = 59
- ibool_superbrick(3, 25) = 44
- ibool_superbrick(4, 25) = 48
- ibool_superbrick(5, 25) = 62
- ibool_superbrick(6, 25) = 60
- ibool_superbrick(7, 25) = 43
- ibool_superbrick(8, 25) = 47
-
- ibool_superbrick(1, 26) = 65
- ibool_superbrick(2, 26) = 63
- ibool_superbrick(3, 26) = 59
- ibool_superbrick(4, 26) = 61
- ibool_superbrick(5, 26) = 66
- ibool_superbrick(6, 26) = 64
- ibool_superbrick(7, 26) = 60
- ibool_superbrick(8, 26) = 62
-
- ibool_superbrick(1, 27) = 65
- ibool_superbrick(2, 27) = 36
- ibool_superbrick(3, 27) = 14
- ibool_superbrick(4, 27) = 56
- ibool_superbrick(5, 27) = 63
- ibool_superbrick(6, 27) = 37
- ibool_superbrick(7, 27) = 13
- ibool_superbrick(8, 27) = 55
-
- ibool_superbrick(1, 28) = 59
- ibool_superbrick(2, 28) = 38
- ibool_superbrick(3, 28) = 19
- ibool_superbrick(4, 28) = 44
- ibool_superbrick(5, 28) = 60
- ibool_superbrick(6, 28) = 39
- ibool_superbrick(7, 28) = 20
- ibool_superbrick(8, 28) = 43
-
- ibool_superbrick(1, 29) = 65
- ibool_superbrick(2, 29) = 63
- ibool_superbrick(3, 29) = 55
- ibool_superbrick(4, 29) = 56
- ibool_superbrick(5, 29) = 61
- ibool_superbrick(6, 29) = 59
- ibool_superbrick(7, 29) = 44
- ibool_superbrick(8, 29) = 48
-
- ibool_superbrick(1, 30) = 63
- ibool_superbrick(2, 30) = 37
- ibool_superbrick(3, 30) = 38
- ibool_superbrick(4, 30) = 59
- ibool_superbrick(5, 30) = 64
- ibool_superbrick(6, 30) = 40
- ibool_superbrick(7, 30) = 39
- ibool_superbrick(8, 30) = 60
-
- ibool_superbrick(1, 31) = 63
- ibool_superbrick(2, 31) = 37
- ibool_superbrick(3, 31) = 13
- ibool_superbrick(4, 31) = 55
- ibool_superbrick(5, 31) = 59
- ibool_superbrick(6, 31) = 38
- ibool_superbrick(7, 31) = 19
- ibool_superbrick(8, 31) = 44
-
- ibool_superbrick(1, 32) = 67
- ibool_superbrick(2, 32) = 42
- ibool_superbrick(3, 32) = 24
- ibool_superbrick(4, 32) = 57
- ibool_superbrick(5, 32) = 65
- ibool_superbrick(6, 32) = 36
- ibool_superbrick(7, 32) = 14
- ibool_superbrick(8, 32) = 56
-
-
- iboun_sb(:,:) = .false.
-
- iboun_sb(1,2) = .true.
- iboun_sb(1,6) = .true.
- iboun_sb(2,2) = .true.
- iboun_sb(2,4) = .true.
- iboun_sb(2,6) = .true.
- iboun_sb(3,4) = .true.
- iboun_sb(4,6) = .true.
- iboun_sb(5,2) = .true.
- iboun_sb(6,4) = .true.
- iboun_sb(6,6) = .true.
- iboun_sb(8,2) = .true.
- iboun_sb(8,4) = .true.
- iboun_sb(8,5) = .true.
- iboun_sb(9,2) = .true.
- iboun_sb(9,6) = .true.
- iboun_sb(10,2) = .true.
- iboun_sb(10,3) = .true.
- iboun_sb(10,6) = .true.
- iboun_sb(11,3) = .true.
- iboun_sb(12,6) = .true.
- iboun_sb(13,2) = .true.
- iboun_sb(14,3) = .true.
- iboun_sb(14,6) = .true.
- iboun_sb(16,2) = .true.
- iboun_sb(16,3) = .true.
- iboun_sb(16,5) = .true.
- iboun_sb(17,1) = .true.
- iboun_sb(17,6) = .true.
- iboun_sb(18,1) = .true.
- iboun_sb(18,4) = .true.
- iboun_sb(18,6) = .true.
- iboun_sb(19,4) = .true.
- iboun_sb(20,6) = .true.
- iboun_sb(21,1) = .true.
- iboun_sb(22,4) = .true.
- iboun_sb(22,6) = .true.
- iboun_sb(24,1) = .true.
- iboun_sb(24,4) = .true.
- iboun_sb(24,5) = .true.
- iboun_sb(25,1) = .true.
- iboun_sb(25,6) = .true.
- iboun_sb(26,1) = .true.
- iboun_sb(26,3) = .true.
- iboun_sb(26,6) = .true.
- iboun_sb(27,3) = .true.
- iboun_sb(28,6) = .true.
- iboun_sb(29,1) = .true.
- iboun_sb(30,3) = .true.
- iboun_sb(30,6) = .true.
- iboun_sb(32,1) = .true.
- iboun_sb(32,3) = .true.
- iboun_sb(32,5) = .true.
-
- end subroutine define_superbrick
-
-
- subroutine define_superbrick_one_layer(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
-
- implicit none
-
- include "constants.h"
-
- integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
- double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
- logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
-
-x_superbrick(1) = 3.d0 / 2.d0
-y_superbrick(1) = 1.d0
-z_superbrick(1) = 1.d0
-
-x_superbrick(2) = 3.d0 / 2.d0
-y_superbrick(2) = 1.d0
-z_superbrick(2) = 2.d0 / 3.d0
-
-x_superbrick(3) = 3.d0 / 2.d0
-y_superbrick(3) = 3.d0 / 2.d0
-z_superbrick(3) = 2.d0 / 3.d0
-
-x_superbrick(4) = 3.d0 / 2.d0
-y_superbrick(4) = 3.d0 / 2.d0
-z_superbrick(4) = 1.d0
-
-x_superbrick(5) = 2.d0
-y_superbrick(5) = 1.d0
-z_superbrick(5) = 1.d0
-
-x_superbrick(6) = 2.d0
-y_superbrick(6) = 1.d0
-z_superbrick(6) = 1.d0 / 3.d0
-
-x_superbrick(7) = 2.d0
-y_superbrick(7) = 3.d0 / 2.d0
-z_superbrick(7) = 1.d0 / 3.d0
-
-x_superbrick(8) = 2.d0
-y_superbrick(8) = 3.d0 / 2.d0
-z_superbrick(8) = 1.d0
-
-x_superbrick(9) = 3.d0 / 2.d0
-y_superbrick(9) = 2.d0
-z_superbrick(9) = 1.d0 / 3.d0
-
-x_superbrick(10) = 3.d0 / 2.d0
-y_superbrick(10) = 2.d0
-z_superbrick(10) = 1.d0
-
-x_superbrick(11) = 2.d0
-y_superbrick(11) = 2.d0
-z_superbrick(11) = 0.d0
-
-x_superbrick(12) = 2.d0
-y_superbrick(12) = 2.d0
-z_superbrick(12) = 1.d0
-
-x_superbrick(13) = 1.d0
-y_superbrick(13) = 1.d0
-z_superbrick(13) = 1.d0 / 3.d0
-
-x_superbrick(14) = 1.d0
-y_superbrick(14) = 1.d0
-z_superbrick(14) = 0.d0
-
-x_superbrick(15) = 1.d0
-y_superbrick(15) = 2.d0
-z_superbrick(15) = 0.d0
-
-x_superbrick(16) = 1.d0
-y_superbrick(16) = 2.d0
-z_superbrick(16) = 1.d0 / 3.d0
-
-x_superbrick(17) = 3.d0 / 2.d0
-y_superbrick(17) = 1.d0
-z_superbrick(17) = 1.d0 / 3.d0
-
-x_superbrick(18) = 2.d0
-y_superbrick(18) = 1.d0
-z_superbrick(18) = 0.d0
-
-x_superbrick(19) = 1.d0
-y_superbrick(19) = 1.d0
-z_superbrick(19) = 2.d0 / 3.d0
-
-x_superbrick(20) = 1.d0
-y_superbrick(20) = 1.d0
-z_superbrick(20) = 1.d0
-
-x_superbrick(21) = 1.d0
-y_superbrick(21) = 3.d0 / 2.d0
-z_superbrick(21) = 2.d0 / 3.d0
-
-x_superbrick(22) = 1.d0
-y_superbrick(22) = 3.d0 / 2.d0
-z_superbrick(22) = 1.d0
-
-x_superbrick(23) = 1.d0
-y_superbrick(23) = 2.d0
-z_superbrick(23) = 1.d0
-
-x_superbrick(24) = 3.d0 / 2.d0
-y_superbrick(24) = 1.d0 / 2.d0
-z_superbrick(24) = 2.d0 / 3.d0
-
-x_superbrick(25) = 3.d0 / 2.d0
-y_superbrick(25) = 1.d0 / 2.d0
-z_superbrick(25) = 1.d0
-
-x_superbrick(26) = 2.d0
-y_superbrick(26) = 1.d0 / 2.d0
-z_superbrick(26) = 1.d0 / 3.d0
-
-x_superbrick(27) = 2.d0
-y_superbrick(27) = 1.d0 / 2.d0
-z_superbrick(27) = 1.d0
-
-x_superbrick(28) = 3.d0 / 2.d0
-y_superbrick(28) = 0.d0
-z_superbrick(28) = 1.d0 / 3.d0
-
-x_superbrick(29) = 3.d0 / 2.d0
-y_superbrick(29) = 0.d0
-z_superbrick(29) = 1.d0
-
-x_superbrick(30) = 2.d0
-y_superbrick(30) = 0.d0
-z_superbrick(30) = 0.d0
-
-x_superbrick(31) = 2.d0
-y_superbrick(31) = 0.d0
-z_superbrick(31) = 1.d0
-
-x_superbrick(32) = 1.d0
-y_superbrick(32) = 0.d0
-z_superbrick(32) = 0.d0
-
-x_superbrick(33) = 1.d0
-y_superbrick(33) = 0.d0
-z_superbrick(33) = 1.d0 / 3.d0
-
-x_superbrick(34) = 1.d0
-y_superbrick(34) = 1.d0 / 2.d0
-z_superbrick(34) = 2.d0 / 3.d0
-
-x_superbrick(35) = 1.d0
-y_superbrick(35) = 1.d0 / 2.d0
-z_superbrick(35) = 1.d0
-
-x_superbrick(36) = 1.d0
-y_superbrick(36) = 0.d0
-z_superbrick(36) = 1.d0
-
-x_superbrick(37) = 1.d0 / 2.d0
-y_superbrick(37) = 1.d0
-z_superbrick(37) = 1.d0
-
-x_superbrick(38) = 1.d0 / 2.d0
-y_superbrick(38) = 1.d0
-z_superbrick(38) = 2.d0 / 3.d0
-
-x_superbrick(39) = 1.d0 / 2.d0
-y_superbrick(39) = 3.d0 / 2.d0
-z_superbrick(39) = 2.d0 / 3.d0
-
-x_superbrick(40) = 1.d0 / 2.d0
-y_superbrick(40) = 3.d0 / 2.d0
-z_superbrick(40) = 1.d0
-
-x_superbrick(41) = 0.d0
-y_superbrick(41) = 1.d0
-z_superbrick(41) = 1.d0
-
-x_superbrick(42) = 0.d0
-y_superbrick(42) = 1.d0
-z_superbrick(42) = 1.d0 / 3.d0
-
-x_superbrick(43) = 0.d0
-y_superbrick(43) = 3.d0 / 2.d0
-z_superbrick(43) = 1.d0 / 3.d0
-
-x_superbrick(44) = 0.d0
-y_superbrick(44) = 3.d0 / 2.d0
-z_superbrick(44) = 1.d0
-
-x_superbrick(45) = 1.d0 / 2.d0
-y_superbrick(45) = 2.d0
-z_superbrick(45) = 1.d0 / 3.d0
-
-x_superbrick(46) = 1.d0 / 2.d0
-y_superbrick(46) = 2.d0
-z_superbrick(46) = 1.d0
-
-x_superbrick(47) = 0.d0
-y_superbrick(47) = 2.d0
-z_superbrick(47) = 0.d0
-
-x_superbrick(48) = 0.d0
-y_superbrick(48) = 2.d0
-z_superbrick(48) = 1.d0
-
-x_superbrick(49) = 1.d0 / 2.d0
-y_superbrick(49) = 1.d0
-z_superbrick(49) = 1.d0 / 3.d0
-
-x_superbrick(50) = 0.d0
-y_superbrick(50) = 1.d0
-z_superbrick(50) = 0.d0
-
-x_superbrick(51) = 1.d0 / 2.d0
-y_superbrick(51) = 1.d0 / 2.d0
-z_superbrick(51) = 2.d0 / 3.d0
-
-x_superbrick(52) = 1.d0 / 2.d0
-y_superbrick(52) = 1.d0 / 2.d0
-z_superbrick(52) = 1.d0
-
-x_superbrick(53) = 0.d0
-y_superbrick(53) = 1.d0 / 2.d0
-z_superbrick(53) = 1.d0 / 3.d0
-
-x_superbrick(54) = 0.d0
-y_superbrick(54) = 1.d0 / 2.d0
-z_superbrick(54) = 1.d0
-
-x_superbrick(55) = 1.d0 / 2.d0
-y_superbrick(55) = 0.d0
-z_superbrick(55) = 1.d0 / 3.d0
-
-x_superbrick(56) = 1.d0 / 2.d0
-y_superbrick(56) = 0.d0
-z_superbrick(56) = 1.d0
-
-x_superbrick(57) = 0.d0
-y_superbrick(57) = 0.d0
-z_superbrick(57) = 0.d0
-
-x_superbrick(58) = 0.d0
-y_superbrick(58) = 0.d0
-z_superbrick(58) = 1.d0
-
-ibool_superbrick(1, 1) = 2
-ibool_superbrick(2, 1) = 6
-ibool_superbrick(3, 1) = 7
-ibool_superbrick(4, 1) = 3
-ibool_superbrick(5, 1) = 1
-ibool_superbrick(6, 1) = 5
-ibool_superbrick(7, 1) = 8
-ibool_superbrick(8, 1) = 4
-
-ibool_superbrick(1, 2) = 3
-ibool_superbrick(2, 2) = 7
-ibool_superbrick(3, 2) = 11
-ibool_superbrick(4, 2) = 9
-ibool_superbrick(5, 2) = 4
-ibool_superbrick(6, 2) = 8
-ibool_superbrick(7, 2) = 12
-ibool_superbrick(8, 2) = 10
-
-ibool_superbrick(1, 3) = 14
-ibool_superbrick(2, 3) = 18
-ibool_superbrick(3, 3) = 11
-ibool_superbrick(4, 3) = 15
-ibool_superbrick(5, 3) = 13
-ibool_superbrick(6, 3) = 17
-ibool_superbrick(7, 3) = 9
-ibool_superbrick(8, 3) = 16
-
-ibool_superbrick(1, 4) = 19
-ibool_superbrick(2, 4) = 2
-ibool_superbrick(3, 4) = 3
-ibool_superbrick(4, 4) = 21
-ibool_superbrick(5, 4) = 20
-ibool_superbrick(6, 4) = 1
-ibool_superbrick(7, 4) = 4
-ibool_superbrick(8, 4) = 22
-
-ibool_superbrick(1, 5) = 17
-ibool_superbrick(2, 5) = 18
-ibool_superbrick(3, 5) = 11
-ibool_superbrick(4, 5) = 9
-ibool_superbrick(5, 5) = 2
-ibool_superbrick(6, 5) = 6
-ibool_superbrick(7, 5) = 7
-ibool_superbrick(8, 5) = 3
-
-ibool_superbrick(1, 6) = 21
-ibool_superbrick(2, 6) = 3
-ibool_superbrick(3, 6) = 9
-ibool_superbrick(4, 6) = 16
-ibool_superbrick(5, 6) = 22
-ibool_superbrick(6, 6) = 4
-ibool_superbrick(7, 6) = 10
-ibool_superbrick(8, 6) = 23
-
-ibool_superbrick(1, 7) = 13
-ibool_superbrick(2, 7) = 17
-ibool_superbrick(3, 7) = 9
-ibool_superbrick(4, 7) = 16
-ibool_superbrick(5, 7) = 19
-ibool_superbrick(6, 7) = 2
-ibool_superbrick(7, 7) = 3
-ibool_superbrick(8, 7) = 21
-
-ibool_superbrick(1, 8) = 24
-ibool_superbrick(2, 8) = 26
-ibool_superbrick(3, 8) = 6
-ibool_superbrick(4, 8) = 2
-ibool_superbrick(5, 8) = 25
-ibool_superbrick(6, 8) = 27
-ibool_superbrick(7, 8) = 5
-ibool_superbrick(8, 8) = 1
-
-ibool_superbrick(1, 9) = 28
-ibool_superbrick(2, 9) = 30
-ibool_superbrick(3, 9) = 26
-ibool_superbrick(4, 9) = 24
-ibool_superbrick(5, 9) = 29
-ibool_superbrick(6, 9) = 31
-ibool_superbrick(7, 9) = 27
-ibool_superbrick(8, 9) = 25
-
-ibool_superbrick(1, 10) = 32
-ibool_superbrick(2, 10) = 30
-ibool_superbrick(3, 10) = 18
-ibool_superbrick(4, 10) = 14
-ibool_superbrick(5, 10) = 33
-ibool_superbrick(6, 10) = 28
-ibool_superbrick(7, 10) = 17
-ibool_superbrick(8, 10) = 13
-
-ibool_superbrick(1, 11) = 34
-ibool_superbrick(2, 11) = 24
-ibool_superbrick(3, 11) = 2
-ibool_superbrick(4, 11) = 19
-ibool_superbrick(5, 11) = 35
-ibool_superbrick(6, 11) = 25
-ibool_superbrick(7, 11) = 1
-ibool_superbrick(8, 11) = 20
-
-ibool_superbrick(1, 12) = 28
-ibool_superbrick(2, 12) = 30
-ibool_superbrick(3, 12) = 18
-ibool_superbrick(4, 12) = 17
-ibool_superbrick(5, 12) = 24
-ibool_superbrick(6, 12) = 26
-ibool_superbrick(7, 12) = 6
-ibool_superbrick(8, 12) = 2
-
-ibool_superbrick(1, 13) = 33
-ibool_superbrick(2, 13) = 28
-ibool_superbrick(3, 13) = 24
-ibool_superbrick(4, 13) = 34
-ibool_superbrick(5, 13) = 36
-ibool_superbrick(6, 13) = 29
-ibool_superbrick(7, 13) = 25
-ibool_superbrick(8, 13) = 35
-
-ibool_superbrick(1, 14) = 33
-ibool_superbrick(2, 14) = 28
-ibool_superbrick(3, 14) = 17
-ibool_superbrick(4, 14) = 13
-ibool_superbrick(5, 14) = 34
-ibool_superbrick(6, 14) = 24
-ibool_superbrick(7, 14) = 2
-ibool_superbrick(8, 14) = 19
-
-ibool_superbrick(1, 15) = 42
-ibool_superbrick(2, 15) = 38
-ibool_superbrick(3, 15) = 39
-ibool_superbrick(4, 15) = 43
-ibool_superbrick(5, 15) = 41
-ibool_superbrick(6, 15) = 37
-ibool_superbrick(7, 15) = 40
-ibool_superbrick(8, 15) = 44
-
-ibool_superbrick(1, 16) = 43
-ibool_superbrick(2, 16) = 39
-ibool_superbrick(3, 16) = 45
-ibool_superbrick(4, 16) = 47
-ibool_superbrick(5, 16) = 44
-ibool_superbrick(6, 16) = 40
-ibool_superbrick(7, 16) = 46
-ibool_superbrick(8, 16) = 48
-
-ibool_superbrick(1, 17) = 50
-ibool_superbrick(2, 17) = 14
-ibool_superbrick(3, 17) = 15
-ibool_superbrick(4, 17) = 47
-ibool_superbrick(5, 17) = 49
-ibool_superbrick(6, 17) = 13
-ibool_superbrick(7, 17) = 16
-ibool_superbrick(8, 17) = 45
-
-ibool_superbrick(1, 18) = 38
-ibool_superbrick(2, 18) = 19
-ibool_superbrick(3, 18) = 21
-ibool_superbrick(4, 18) = 39
-ibool_superbrick(5, 18) = 37
-ibool_superbrick(6, 18) = 20
-ibool_superbrick(7, 18) = 22
-ibool_superbrick(8, 18) = 40
-
-ibool_superbrick(1, 19) = 50
-ibool_superbrick(2, 19) = 49
-ibool_superbrick(3, 19) = 45
-ibool_superbrick(4, 19) = 47
-ibool_superbrick(5, 19) = 42
-ibool_superbrick(6, 19) = 38
-ibool_superbrick(7, 19) = 39
-ibool_superbrick(8, 19) = 43
-
-ibool_superbrick(1, 20) = 39
-ibool_superbrick(2, 20) = 21
-ibool_superbrick(3, 20) = 16
-ibool_superbrick(4, 20) = 45
-ibool_superbrick(5, 20) = 40
-ibool_superbrick(6, 20) = 22
-ibool_superbrick(7, 20) = 23
-ibool_superbrick(8, 20) = 46
-
-ibool_superbrick(1, 21) = 49
-ibool_superbrick(2, 21) = 13
-ibool_superbrick(3, 21) = 16
-ibool_superbrick(4, 21) = 45
-ibool_superbrick(5, 21) = 38
-ibool_superbrick(6, 21) = 19
-ibool_superbrick(7, 21) = 21
-ibool_superbrick(8, 21) = 39
-
-ibool_superbrick(1, 22) = 53
-ibool_superbrick(2, 22) = 51
-ibool_superbrick(3, 22) = 38
-ibool_superbrick(4, 22) = 42
-ibool_superbrick(5, 22) = 54
-ibool_superbrick(6, 22) = 52
-ibool_superbrick(7, 22) = 37
-ibool_superbrick(8, 22) = 41
-
-ibool_superbrick(1, 23) = 57
-ibool_superbrick(2, 23) = 55
-ibool_superbrick(3, 23) = 51
-ibool_superbrick(4, 23) = 53
-ibool_superbrick(5, 23) = 58
-ibool_superbrick(6, 23) = 56
-ibool_superbrick(7, 23) = 52
-ibool_superbrick(8, 23) = 54
-
-ibool_superbrick(1, 24) = 57
-ibool_superbrick(2, 24) = 32
-ibool_superbrick(3, 24) = 14
-ibool_superbrick(4, 24) = 50
-ibool_superbrick(5, 24) = 55
-ibool_superbrick(6, 24) = 33
-ibool_superbrick(7, 24) = 13
-ibool_superbrick(8, 24) = 49
-
-ibool_superbrick(1, 25) = 51
-ibool_superbrick(2, 25) = 34
-ibool_superbrick(3, 25) = 19
-ibool_superbrick(4, 25) = 38
-ibool_superbrick(5, 25) = 52
-ibool_superbrick(6, 25) = 35
-ibool_superbrick(7, 25) = 20
-ibool_superbrick(8, 25) = 37
-
-ibool_superbrick(1, 26) = 57
-ibool_superbrick(2, 26) = 55
-ibool_superbrick(3, 26) = 49
-ibool_superbrick(4, 26) = 50
-ibool_superbrick(5, 26) = 53
-ibool_superbrick(6, 26) = 51
-ibool_superbrick(7, 26) = 38
-ibool_superbrick(8, 26) = 42
-
-ibool_superbrick(1, 27) = 55
-ibool_superbrick(2, 27) = 33
-ibool_superbrick(3, 27) = 34
-ibool_superbrick(4, 27) = 51
-ibool_superbrick(5, 27) = 56
-ibool_superbrick(6, 27) = 36
-ibool_superbrick(7, 27) = 35
-ibool_superbrick(8, 27) = 52
-
-ibool_superbrick(1, 28) = 55
-ibool_superbrick(2, 28) = 33
-ibool_superbrick(3, 28) = 13
-ibool_superbrick(4, 28) = 49
-ibool_superbrick(5, 28) = 51
-ibool_superbrick(6, 28) = 34
-ibool_superbrick(7, 28) = 19
-ibool_superbrick(8, 28) = 38
-
-iboun_sb(:,:) = .false.
-iboun_sb(1,2) = .true.
-iboun_sb(1,6) = .true.
-iboun_sb(2,2) = .true.
-iboun_sb(2,4) = .true.
-iboun_sb(2,6) = .true.
-iboun_sb(3,4) = .true.
-iboun_sb(3,5) = .true.
-iboun_sb(4,6) = .true.
-iboun_sb(5,2) = .true.
-iboun_sb(6,4) = .true.
-iboun_sb(6,6) = .true.
-iboun_sb(8,2) = .true.
-iboun_sb(8,6) = .true.
-iboun_sb(9,2) = .true.
-iboun_sb(9,3) = .true.
-iboun_sb(9,6) = .true.
-iboun_sb(10,3) = .true.
-iboun_sb(10,5) = .true.
-iboun_sb(11,6) = .true.
-iboun_sb(12,2) = .true.
-iboun_sb(13,3) = .true.
-iboun_sb(13,6) = .true.
-iboun_sb(15,1) = .true.
-iboun_sb(15,6) = .true.
-iboun_sb(16,1) = .true.
-iboun_sb(16,4) = .true.
-iboun_sb(16,6) = .true.
-iboun_sb(17,4) = .true.
-iboun_sb(17,5) = .true.
-iboun_sb(18,6) = .true.
-iboun_sb(19,1) = .true.
-iboun_sb(20,4) = .true.
-iboun_sb(20,6) = .true.
-iboun_sb(22,1) = .true.
-iboun_sb(22,6) = .true.
-iboun_sb(23,1) = .true.
-iboun_sb(23,3) = .true.
-iboun_sb(23,6) = .true.
-iboun_sb(24,3) = .true.
-iboun_sb(24,5) = .true.
-iboun_sb(25,6) = .true.
-iboun_sb(26,1) = .true.
-iboun_sb(27,3) = .true.
-iboun_sb(27,6) = .true.
-
-end subroutine define_superbrick_one_layer
-
-
-subroutine define_basic_doubling_brick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb,case_num)
-
- implicit none
-
- include "constants.h"
-
- integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
- double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
- logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
- integer :: case_num
-
- SELECT CASE (case_num)
- CASE (1)
- x_superbrick(1) = 1.d0 / 2.d0
- y_superbrick(1) = 1.d0
- z_superbrick(1) = 2.d0
-
- x_superbrick(2) = 1.d0 / 2.d0
- y_superbrick(2) = 1.d0
- z_superbrick(2) = 3.d0 / 2.d0
-
- x_superbrick(3) = 1.d0 / 2.d0
- y_superbrick(3) = 1.d0 / 2.d0
- z_superbrick(3) = 3.d0 / 2.d0
-
- x_superbrick(4) = 1.d0 / 2.d0
- y_superbrick(4) = 1.d0 / 2.d0
- z_superbrick(4) = 2.d0
-
- x_superbrick(5) = 0.d0
- y_superbrick(5) = 1.d0
- z_superbrick(5) = 2.d0
-
- x_superbrick(6) = 0.d0
- y_superbrick(6) = 1.d0
- z_superbrick(6) = 1.d0
-
- x_superbrick(7) = 0.d0
- y_superbrick(7) = 1.d0 / 2.d0
- z_superbrick(7) = 1.d0
-
- x_superbrick(8) = 0.d0
- y_superbrick(8) = 1.d0 / 2.d0
- z_superbrick(8) = 2.d0
-
- x_superbrick(9) = 1.d0 / 2.d0
- y_superbrick(9) = 0.d0
- z_superbrick(9) = 1.d0
-
- x_superbrick(10) = 1.d0 / 2.d0
- y_superbrick(10) = 0.d0
- z_superbrick(10) = 2.d0
-
- x_superbrick(11) = 0.d0
- y_superbrick(11) = 0.d0
- z_superbrick(11) = 1.d0 / 2.d0
-
- x_superbrick(12) = 0.d0
- y_superbrick(12) = 0.d0
- z_superbrick(12) = 2.d0
-
- x_superbrick(13) = 1.d0
- y_superbrick(13) = 1.d0
- z_superbrick(13) = 1.d0
-
- x_superbrick(14) = 1.d0
- y_superbrick(14) = 1.d0
- z_superbrick(14) = 1.d0 / 2.d0
-
- x_superbrick(15) = 1.d0
- y_superbrick(15) = 0.d0
- z_superbrick(15) = 1.d0 / 2.d0
-
- x_superbrick(16) = 1.d0
- y_superbrick(16) = 0.d0
- z_superbrick(16) = 1.d0
-
- x_superbrick(17) = 1.d0 / 2.d0
- y_superbrick(17) = 1.d0
- z_superbrick(17) = 1.d0
-
- x_superbrick(18) = 0.d0
- y_superbrick(18) = 1.d0
- z_superbrick(18) = 1.d0 / 2.d0
-
- x_superbrick(19) = 1.d0
- y_superbrick(19) = 1.d0
- z_superbrick(19) = 3.d0 / 2.d0
-
- x_superbrick(20) = 1.d0
- y_superbrick(20) = 1.d0
- z_superbrick(20) = 2.d0
-
- x_superbrick(21) = 1.d0
- y_superbrick(21) = 1.d0 / 2.d0
- z_superbrick(21) = 3.d0 / 2.d0
-
- x_superbrick(22) = 1.d0
- y_superbrick(22) = 1.d0 / 2.d0
- z_superbrick(22) = 2.d0
-
- x_superbrick(23) = 1.d0
- y_superbrick(23) = 0.d0
- z_superbrick(23) = 2.d0
-
- x_superbrick(24) = 1.d0
- y_superbrick(24) = 1.d0
- z_superbrick(24) = 0.d0
-
- x_superbrick(25) = 0.d0
- y_superbrick(25) = 1.d0
- z_superbrick(25) = 0.d0
-
- x_superbrick(26) = 0.d0
- y_superbrick(26) = 0.d0
- z_superbrick(26) = 0.d0
-
- x_superbrick(27) = 1.d0
- y_superbrick(27) = 0.d0
- z_superbrick(27) = 0.d0
-
- ibool_superbrick(1, 1) = 7
- ibool_superbrick(2, 1) = 3
- ibool_superbrick(3, 1) = 2
- ibool_superbrick(4, 1) = 6
- ibool_superbrick(5, 1) = 8
- ibool_superbrick(6, 1) = 4
- ibool_superbrick(7, 1) = 1
- ibool_superbrick(8, 1) = 5
-
- ibool_superbrick(1, 2) = 11
- ibool_superbrick(2, 2) = 9
- ibool_superbrick(3, 2) = 3
- ibool_superbrick(4, 2) = 7
- ibool_superbrick(5, 2) = 12
- ibool_superbrick(6, 2) = 10
- ibool_superbrick(7, 2) = 4
- ibool_superbrick(8, 2) = 8
-
- ibool_superbrick(1, 3) = 11
- ibool_superbrick(2, 3) = 15
- ibool_superbrick(3, 3) = 14
- ibool_superbrick(4, 3) = 18
- ibool_superbrick(5, 3) = 9
- ibool_superbrick(6, 3) = 16
- ibool_superbrick(7, 3) = 13
- ibool_superbrick(8, 3) = 17
-
- ibool_superbrick(1, 4) = 3
- ibool_superbrick(2, 4) = 21
- ibool_superbrick(3, 4) = 19
- ibool_superbrick(4, 4) = 2
- ibool_superbrick(5, 4) = 4
- ibool_superbrick(6, 4) = 22
- ibool_superbrick(7, 4) = 20
- ibool_superbrick(8, 4) = 1
-
- ibool_superbrick(1, 5) = 11
- ibool_superbrick(2, 5) = 9
- ibool_superbrick(3, 5) = 17
- ibool_superbrick(4, 5) = 18
- ibool_superbrick(5, 5) = 7
- ibool_superbrick(6, 5) = 3
- ibool_superbrick(7, 5) = 2
- ibool_superbrick(8, 5) = 6
-
- ibool_superbrick(1, 6) = 9
- ibool_superbrick(2, 6) = 16
- ibool_superbrick(3, 6) = 21
- ibool_superbrick(4, 6) = 3
- ibool_superbrick(5, 6) = 10
- ibool_superbrick(6, 6) = 23
- ibool_superbrick(7, 6) = 22
- ibool_superbrick(8, 6) = 4
-
- ibool_superbrick(1, 7) = 9
- ibool_superbrick(2, 7) = 16
- ibool_superbrick(3, 7) = 13
- ibool_superbrick(4, 7) = 17
- ibool_superbrick(5, 7) = 3
- ibool_superbrick(6, 7) = 21
- ibool_superbrick(7, 7) = 19
- ibool_superbrick(8, 7) = 2
-
- ibool_superbrick(1, 8) = 26
- ibool_superbrick(2, 8) = 27
- ibool_superbrick(3, 8) = 24
- ibool_superbrick(4, 8) = 25
- ibool_superbrick(5, 8) = 11
- ibool_superbrick(6, 8) = 15
- ibool_superbrick(7, 8) = 14
- ibool_superbrick(8, 8) = 18
-
- iboun_sb(:,:) = .false.
- iboun_sb(1,1) = .true.
- iboun_sb(1,4) = .true.
- iboun_sb(1,6) = .true.
- iboun_sb(2,1) = .true.
- iboun_sb(2,3) = .true.
- iboun_sb(2,6) = .true.
- iboun_sb(3,2) = .true.
- iboun_sb(3,3) = .true.
- iboun_sb(3,4) = .true.
- iboun_sb(4,2) = .true.
- iboun_sb(4,4) = .true.
- iboun_sb(4,6) = .true.
- iboun_sb(5,1) = .true.
- iboun_sb(5,4) = .true.
- iboun_sb(6,2) = .true.
- iboun_sb(6,3) = .true.
- iboun_sb(6,6) = .true.
- iboun_sb(7,2) = .true.
- iboun_sb(7,4) = .true.
- iboun_sb(8,1) = .true.
- iboun_sb(8,2) = .true.
- iboun_sb(8,3) = .true.
- iboun_sb(8,4) = .true.
- iboun_sb(8,5) = .true.
- CASE (2)
- x_superbrick(1) = 1.d0 / 2.d0
- y_superbrick(1) = 0.d0
- z_superbrick(1) = 2.d0
-
- x_superbrick(2) = 1.d0 / 2.d0
- y_superbrick(2) = 0.d0
- z_superbrick(2) = 3.d0 / 2.d0
-
- x_superbrick(3) = 1.d0 / 2.d0
- y_superbrick(3) = 1.d0 / 2.d0
- z_superbrick(3) = 3.d0 / 2.d0
-
- x_superbrick(4) = 1.d0 / 2.d0
- y_superbrick(4) = 1.d0 / 2.d0
- z_superbrick(4) = 2.d0
-
- x_superbrick(5) = 0.d0
- y_superbrick(5) = 0.d0
- z_superbrick(5) = 2.d0
-
- x_superbrick(6) = 0.d0
- y_superbrick(6) = 0.d0
- z_superbrick(6) = 1.d0
-
- x_superbrick(7) = 0.d0
- y_superbrick(7) = 1.d0 / 2.d0
- z_superbrick(7) = 1.d0
-
- x_superbrick(8) = 0.d0
- y_superbrick(8) = 1.d0 / 2.d0
- z_superbrick(8) = 2.d0
-
- x_superbrick(9) = 1.d0 / 2.d0
- y_superbrick(9) = 1.d0
- z_superbrick(9) = 1.d0
-
- x_superbrick(10) = 1.d0 / 2.d0
- y_superbrick(10) = 1.d0
- z_superbrick(10) = 2.d0
-
- x_superbrick(11) = 0.d0
- y_superbrick(11) = 1.d0
- z_superbrick(11) = 1.d0 / 2.d0
-
- x_superbrick(12) = 0.d0
- y_superbrick(12) = 1.d0
- z_superbrick(12) = 2.d0
-
- x_superbrick(13) = 1.d0
- y_superbrick(13) = 0.d0
- z_superbrick(13) = 1.d0
-
- x_superbrick(14) = 1.d0
- y_superbrick(14) = 0.d0
- z_superbrick(14) = 1.d0 / 2.d0
-
- x_superbrick(15) = 1.d0
- y_superbrick(15) = 1.d0
- z_superbrick(15) = 1.d0 / 2.d0
-
- x_superbrick(16) = 1.d0
- y_superbrick(16) = 1.d0
- z_superbrick(16) = 1.d0
-
- x_superbrick(17) = 1.d0 / 2.d0
- y_superbrick(17) = 0.d0
- z_superbrick(17) = 1.d0
-
- x_superbrick(18) = 0.d0
- y_superbrick(18) = 0.d0
- z_superbrick(18) = 1.d0 / 2.d0
-
- x_superbrick(19) = 1.d0
- y_superbrick(19) = 0.d0
- z_superbrick(19) = 3.d0 / 2.d0
-
- x_superbrick(20) = 1.d0
- y_superbrick(20) = 0.d0
- z_superbrick(20) = 2.d0
-
- x_superbrick(21) = 1.d0
- y_superbrick(21) = 1.d0 / 2.d0
- z_superbrick(21) = 3.d0 / 2.d0
-
- x_superbrick(22) = 1.d0
- y_superbrick(22) = 1.d0 / 2.d0
- z_superbrick(22) = 2.d0
-
- x_superbrick(23) = 1.d0
- y_superbrick(23) = 1.d0
- z_superbrick(23) = 2.d0
-
- x_superbrick(24) = 1.d0
- y_superbrick(24) = 0.d0
- z_superbrick(24) = 0.d0
-
- x_superbrick(25) = 0.d0
- y_superbrick(25) = 0.d0
- z_superbrick(25) = 0.d0
-
- x_superbrick(26) = 0.d0
- y_superbrick(26) = 1.d0
- z_superbrick(26) = 0.d0
-
- x_superbrick(27) = 1.d0
- y_superbrick(27) = 1.d0
- z_superbrick(27) = 0.d0
-
- ibool_superbrick(1, 1) = 6
- ibool_superbrick(2, 1) = 2
- ibool_superbrick(3, 1) = 3
- ibool_superbrick(4, 1) = 7
- ibool_superbrick(5, 1) = 5
- ibool_superbrick(6, 1) = 1
- ibool_superbrick(7, 1) = 4
- ibool_superbrick(8, 1) = 8
-
- ibool_superbrick(1, 2) = 7
- ibool_superbrick(2, 2) = 3
- ibool_superbrick(3, 2) = 9
- ibool_superbrick(4, 2) = 11
- ibool_superbrick(5, 2) = 8
- ibool_superbrick(6, 2) = 4
- ibool_superbrick(7, 2) = 10
- ibool_superbrick(8, 2) = 12
-
- ibool_superbrick(1, 3) = 18
- ibool_superbrick(2, 3) = 14
- ibool_superbrick(3, 3) = 15
- ibool_superbrick(4, 3) = 11
- ibool_superbrick(5, 3) = 17
- ibool_superbrick(6, 3) = 13
- ibool_superbrick(7, 3) = 16
- ibool_superbrick(8, 3) = 9
-
- ibool_superbrick(1, 4) = 2
- ibool_superbrick(2, 4) = 19
- ibool_superbrick(3, 4) = 21
- ibool_superbrick(4, 4) = 3
- ibool_superbrick(5, 4) = 1
- ibool_superbrick(6, 4) = 20
- ibool_superbrick(7, 4) = 22
- ibool_superbrick(8, 4) = 4
-
- ibool_superbrick(1, 5) = 18
- ibool_superbrick(2, 5) = 17
- ibool_superbrick(3, 5) = 9
- ibool_superbrick(4, 5) = 11
- ibool_superbrick(5, 5) = 6
- ibool_superbrick(6, 5) = 2
- ibool_superbrick(7, 5) = 3
- ibool_superbrick(8, 5) = 7
-
- ibool_superbrick(1, 6) = 3
- ibool_superbrick(2, 6) = 21
- ibool_superbrick(3, 6) = 16
- ibool_superbrick(4, 6) = 9
- ibool_superbrick(5, 6) = 4
- ibool_superbrick(6, 6) = 22
- ibool_superbrick(7, 6) = 23
- ibool_superbrick(8, 6) = 10
-
- ibool_superbrick(1, 7) = 17
- ibool_superbrick(2, 7) = 13
- ibool_superbrick(3, 7) = 16
- ibool_superbrick(4, 7) = 9
- ibool_superbrick(5, 7) = 2
- ibool_superbrick(6, 7) = 19
- ibool_superbrick(7, 7) = 21
- ibool_superbrick(8, 7) = 3
-
- ibool_superbrick(1, 8) = 25
- ibool_superbrick(2, 8) = 24
- ibool_superbrick(3, 8) = 27
- ibool_superbrick(4, 8) = 26
- ibool_superbrick(5, 8) = 18
- ibool_superbrick(6, 8) = 14
- ibool_superbrick(7, 8) = 15
- ibool_superbrick(8, 8) = 11
-
- iboun_sb(:,:) = .false.
- iboun_sb(1,1) = .true.
- iboun_sb(1,3) = .true.
- iboun_sb(1,6) = .true.
- iboun_sb(2,1) = .true.
- iboun_sb(2,4) = .true.
- iboun_sb(2,6) = .true.
- iboun_sb(3,2) = .true.
- iboun_sb(3,3) = .true.
- iboun_sb(3,4) = .true.
- iboun_sb(4,2) = .true.
- iboun_sb(4,3) = .true.
- iboun_sb(4,6) = .true.
- iboun_sb(5,1) = .true.
- iboun_sb(5,3) = .true.
- iboun_sb(6,2) = .true.
- iboun_sb(6,4) = .true.
- iboun_sb(6,6) = .true.
- iboun_sb(7,2) = .true.
- iboun_sb(7,3) = .true.
- iboun_sb(8,1) = .true.
- iboun_sb(8,2) = .true.
- iboun_sb(8,3) = .true.
- iboun_sb(8,4) = .true.
- iboun_sb(8,5) = .true.
- CASE (3)
- x_superbrick(1) = 1.d0 / 2.d0
- y_superbrick(1) = 1.d0
- z_superbrick(1) = 2.d0
-
- x_superbrick(2) = 1.d0 / 2.d0
- y_superbrick(2) = 1.d0
- z_superbrick(2) = 3.d0 / 2.d0
-
- x_superbrick(3) = 1.d0 / 2.d0
- y_superbrick(3) = 1.d0 / 2.d0
- z_superbrick(3) = 3.d0 / 2.d0
-
- x_superbrick(4) = 1.d0 / 2.d0
- y_superbrick(4) = 1.d0 / 2.d0
- z_superbrick(4) = 2.d0
-
- x_superbrick(5) = 1.d0
- y_superbrick(5) = 1.d0
- z_superbrick(5) = 2.d0
-
- x_superbrick(6) = 1.d0
- y_superbrick(6) = 1.d0
- z_superbrick(6) = 1.d0
-
- x_superbrick(7) = 1.d0
- y_superbrick(7) = 1.d0 / 2.d0
- z_superbrick(7) = 1.d0
-
- x_superbrick(8) = 1.d0
- y_superbrick(8) = 1.d0 / 2.d0
- z_superbrick(8) = 2.d0
-
- x_superbrick(9) = 1.d0 / 2.d0
- y_superbrick(9) = 0.d0
- z_superbrick(9) = 1.d0
-
- x_superbrick(10) = 1.d0 / 2.d0
- y_superbrick(10) = 0.d0
- z_superbrick(10) = 2.d0
-
- x_superbrick(11) = 1.d0
- y_superbrick(11) = 0.d0
- z_superbrick(11) = 1.d0 / 2.d0
-
- x_superbrick(12) = 1.d0
- y_superbrick(12) = 0.d0
- z_superbrick(12) = 2.d0
-
- x_superbrick(13) = 0.d0
- y_superbrick(13) = 1.d0
- z_superbrick(13) = 1.d0
-
- x_superbrick(14) = 0.d0
- y_superbrick(14) = 1.d0
- z_superbrick(14) = 1.d0 / 2.d0
-
- x_superbrick(15) = 0.d0
- y_superbrick(15) = 0.d0
- z_superbrick(15) = 1.d0 / 2.d0
-
- x_superbrick(16) = 0.d0
- y_superbrick(16) = 0.d0
- z_superbrick(16) = 1.d0
-
- x_superbrick(17) = 1.d0 / 2.d0
- y_superbrick(17) = 1.d0
- z_superbrick(17) = 1.d0
-
- x_superbrick(18) = 1.d0
- y_superbrick(18) = 1.d0
- z_superbrick(18) = 1.d0 / 2.d0
-
- x_superbrick(19) = 0.d0
- y_superbrick(19) = 1.d0
- z_superbrick(19) = 3.d0 / 2.d0
-
- x_superbrick(20) = 0.d0
- y_superbrick(20) = 1.d0
- z_superbrick(20) = 2.d0
-
- x_superbrick(21) = 0.d0
- y_superbrick(21) = 1.d0 / 2.d0
- z_superbrick(21) = 3.d0 / 2.d0
-
- x_superbrick(22) = 0.d0
- y_superbrick(22) = 1.d0 / 2.d0
- z_superbrick(22) = 2.d0
-
- x_superbrick(23) = 0.d0
- y_superbrick(23) = 0.d0
- z_superbrick(23) = 2.d0
-
- x_superbrick(24) = 0.d0
- y_superbrick(24) = 1.d0
- z_superbrick(24) = 0.d0
-
- x_superbrick(25) = 1.d0
- y_superbrick(25) = 1.d0
- z_superbrick(25) = 0.d0
-
- x_superbrick(26) = 1.d0
- y_superbrick(26) = 0.d0
- z_superbrick(26) = 0.d0
-
- x_superbrick(27) = 0.d0
- y_superbrick(27) = 0.d0
- z_superbrick(27) = 0.d0
-
- ibool_superbrick(1, 1) = 3
- ibool_superbrick(2, 1) = 7
- ibool_superbrick(3, 1) = 6
- ibool_superbrick(4, 1) = 2
- ibool_superbrick(5, 1) = 4
- ibool_superbrick(6, 1) = 8
- ibool_superbrick(7, 1) = 5
- ibool_superbrick(8, 1) = 1
-
- ibool_superbrick(1, 2) = 9
- ibool_superbrick(2, 2) = 11
- ibool_superbrick(3, 2) = 7
- ibool_superbrick(4, 2) = 3
- ibool_superbrick(5, 2) = 10
- ibool_superbrick(6, 2) = 12
- ibool_superbrick(7, 2) = 8
- ibool_superbrick(8, 2) = 4
-
- ibool_superbrick(1, 3) = 15
- ibool_superbrick(2, 3) = 11
- ibool_superbrick(3, 3) = 18
- ibool_superbrick(4, 3) = 14
- ibool_superbrick(5, 3) = 16
- ibool_superbrick(6, 3) = 9
- ibool_superbrick(7, 3) = 17
- ibool_superbrick(8, 3) = 13
-
- ibool_superbrick(1, 4) = 21
- ibool_superbrick(2, 4) = 3
- ibool_superbrick(3, 4) = 2
- ibool_superbrick(4, 4) = 19
- ibool_superbrick(5, 4) = 22
- ibool_superbrick(6, 4) = 4
- ibool_superbrick(7, 4) = 1
- ibool_superbrick(8, 4) = 20
-
- ibool_superbrick(1, 5) = 9
- ibool_superbrick(2, 5) = 11
- ibool_superbrick(3, 5) = 18
- ibool_superbrick(4, 5) = 17
- ibool_superbrick(5, 5) = 3
- ibool_superbrick(6, 5) = 7
- ibool_superbrick(7, 5) = 6
- ibool_superbrick(8, 5) = 2
-
- ibool_superbrick(1, 6) = 16
- ibool_superbrick(2, 6) = 9
- ibool_superbrick(3, 6) = 3
- ibool_superbrick(4, 6) = 21
- ibool_superbrick(5, 6) = 23
- ibool_superbrick(6, 6) = 10
- ibool_superbrick(7, 6) = 4
- ibool_superbrick(8, 6) = 22
-
- ibool_superbrick(1, 7) = 16
- ibool_superbrick(2, 7) = 9
- ibool_superbrick(3, 7) = 17
- ibool_superbrick(4, 7) = 13
- ibool_superbrick(5, 7) = 21
- ibool_superbrick(6, 7) = 3
- ibool_superbrick(7, 7) = 2
- ibool_superbrick(8, 7) = 19
-
- ibool_superbrick(1, 8) = 27
- ibool_superbrick(2, 8) = 26
- ibool_superbrick(3, 8) = 25
- ibool_superbrick(4, 8) = 24
- ibool_superbrick(5, 8) = 15
- ibool_superbrick(6, 8) = 11
- ibool_superbrick(7, 8) = 18
- ibool_superbrick(8, 8) = 14
-
- iboun_sb(:,:) = .false.
- iboun_sb(1,2) = .true.
- iboun_sb(1,4) = .true.
- iboun_sb(1,6) = .true.
- iboun_sb(2,2) = .true.
- iboun_sb(2,3) = .true.
- iboun_sb(2,6) = .true.
- iboun_sb(3,1) = .true.
- iboun_sb(3,3) = .true.
- iboun_sb(3,4) = .true.
- iboun_sb(4,1) = .true.
- iboun_sb(4,4) = .true.
- iboun_sb(4,6) = .true.
- iboun_sb(5,2) = .true.
- iboun_sb(5,4) = .true.
- iboun_sb(6,1) = .true.
- iboun_sb(6,3) = .true.
- iboun_sb(6,6) = .true.
- iboun_sb(7,1) = .true.
- iboun_sb(7,4) = .true.
- iboun_sb(8,1) = .true.
- iboun_sb(8,2) = .true.
- iboun_sb(8,3) = .true.
- iboun_sb(8,4) = .true.
- iboun_sb(8,5) = .true.
- CASE (4)
- x_superbrick(1) = 1.d0 / 2.d0
- y_superbrick(1) = 0.d0
- z_superbrick(1) = 2.d0
-
- x_superbrick(2) = 1.d0 / 2.d0
- y_superbrick(2) = 0.d0
- z_superbrick(2) = 3.d0 / 2.d0
-
- x_superbrick(3) = 1.d0 / 2.d0
- y_superbrick(3) = 1.d0 / 2.d0
- z_superbrick(3) = 3.d0 / 2.d0
-
- x_superbrick(4) = 1.d0 / 2.d0
- y_superbrick(4) = 1.d0 / 2.d0
- z_superbrick(4) = 2.d0
-
- x_superbrick(5) = 1.d0
- y_superbrick(5) = 0.d0
- z_superbrick(5) = 2.d0
-
- x_superbrick(6) = 1.d0
- y_superbrick(6) = 0.d0
- z_superbrick(6) = 1.d0
-
- x_superbrick(7) = 1.d0
- y_superbrick(7) = 1.d0 / 2.d0
- z_superbrick(7) = 1.d0
-
- x_superbrick(8) = 1.d0
- y_superbrick(8) = 1.d0 / 2.d0
- z_superbrick(8) = 2.d0
-
- x_superbrick(9) = 1.d0 / 2.d0
- y_superbrick(9) = 1.d0
- z_superbrick(9) = 1.d0
-
- x_superbrick(10) = 1.d0 / 2.d0
- y_superbrick(10) = 1.d0
- z_superbrick(10) = 2.d0
-
- x_superbrick(11) = 1.d0
- y_superbrick(11) = 1.d0
- z_superbrick(11) = 1.d0 / 2.d0
-
- x_superbrick(12) = 1.d0
- y_superbrick(12) = 1.d0
- z_superbrick(12) = 2.d0
-
- x_superbrick(13) = 0.d0
- y_superbrick(13) = 0.d0
- z_superbrick(13) = 1.d0
-
- x_superbrick(14) = 0.d0
- y_superbrick(14) = 0.d0
- z_superbrick(14) = 1.d0 / 2.d0
-
- x_superbrick(15) = 0.d0
- y_superbrick(15) = 1.d0
- z_superbrick(15) = 1.d0 / 2.d0
-
- x_superbrick(16) = 0.d0
- y_superbrick(16) = 1.d0
- z_superbrick(16) = 1.d0
-
- x_superbrick(17) = 1.d0 / 2.d0
- y_superbrick(17) = 0.d0
- z_superbrick(17) = 1.d0
-
- x_superbrick(18) = 1.d0
- y_superbrick(18) = 0.d0
- z_superbrick(18) = 1.d0 / 2.d0
-
- x_superbrick(19) = 0.d0
- y_superbrick(19) = 0.d0
- z_superbrick(19) = 3.d0 / 2.d0
-
- x_superbrick(20) = 0.d0
- y_superbrick(20) = 0.d0
- z_superbrick(20) = 2.d0
-
- x_superbrick(21) = 0.d0
- y_superbrick(21) = 1.d0 / 2.d0
- z_superbrick(21) = 3.d0 / 2.d0
-
- x_superbrick(22) = 0.d0
- y_superbrick(22) = 1.d0 / 2.d0
- z_superbrick(22) = 2.d0
-
- x_superbrick(23) = 0.d0
- y_superbrick(23) = 1.d0
- z_superbrick(23) = 2.d0
-
- x_superbrick(24) = 0.d0
- y_superbrick(24) = 0.d0
- z_superbrick(24) = 0.d0
-
- x_superbrick(25) = 1.d0
- y_superbrick(25) = 0.d0
- z_superbrick(25) = 0.d0
-
- x_superbrick(26) = 1.d0
- y_superbrick(26) = 1.d0
- z_superbrick(26) = 0.d0
-
- x_superbrick(27) = 0.d0
- y_superbrick(27) = 1.d0
- z_superbrick(27) = 0.d0
-
- ibool_superbrick(1, 1) = 2
- ibool_superbrick(2, 1) = 6
- ibool_superbrick(3, 1) = 7
- ibool_superbrick(4, 1) = 3
- ibool_superbrick(5, 1) = 1
- ibool_superbrick(6, 1) = 5
- ibool_superbrick(7, 1) = 8
- ibool_superbrick(8, 1) = 4
-
- ibool_superbrick(1, 2) = 3
- ibool_superbrick(2, 2) = 7
- ibool_superbrick(3, 2) = 11
- ibool_superbrick(4, 2) = 9
- ibool_superbrick(5, 2) = 4
- ibool_superbrick(6, 2) = 8
- ibool_superbrick(7, 2) = 12
- ibool_superbrick(8, 2) = 10
-
- ibool_superbrick(1, 3) = 14
- ibool_superbrick(2, 3) = 18
- ibool_superbrick(3, 3) = 11
- ibool_superbrick(4, 3) = 15
- ibool_superbrick(5, 3) = 13
- ibool_superbrick(6, 3) = 17
- ibool_superbrick(7, 3) = 9
- ibool_superbrick(8, 3) = 16
-
- ibool_superbrick(1, 4) = 19
- ibool_superbrick(2, 4) = 2
- ibool_superbrick(3, 4) = 3
- ibool_superbrick(4, 4) = 21
- ibool_superbrick(5, 4) = 20
- ibool_superbrick(6, 4) = 1
- ibool_superbrick(7, 4) = 4
- ibool_superbrick(8, 4) = 22
-
- ibool_superbrick(1, 5) = 17
- ibool_superbrick(2, 5) = 18
- ibool_superbrick(3, 5) = 11
- ibool_superbrick(4, 5) = 9
- ibool_superbrick(5, 5) = 2
- ibool_superbrick(6, 5) = 6
- ibool_superbrick(7, 5) = 7
- ibool_superbrick(8, 5) = 3
-
- ibool_superbrick(1, 6) = 21
- ibool_superbrick(2, 6) = 3
- ibool_superbrick(3, 6) = 9
- ibool_superbrick(4, 6) = 16
- ibool_superbrick(5, 6) = 22
- ibool_superbrick(6, 6) = 4
- ibool_superbrick(7, 6) = 10
- ibool_superbrick(8, 6) = 23
-
- ibool_superbrick(1, 7) = 13
- ibool_superbrick(2, 7) = 17
- ibool_superbrick(3, 7) = 9
- ibool_superbrick(4, 7) = 16
- ibool_superbrick(5, 7) = 19
- ibool_superbrick(6, 7) = 2
- ibool_superbrick(7, 7) = 3
- ibool_superbrick(8, 7) = 21
-
- ibool_superbrick(1, 8) = 24
- ibool_superbrick(2, 8) = 25
- ibool_superbrick(3, 8) = 26
- ibool_superbrick(4, 8) = 27
- ibool_superbrick(5, 8) = 14
- ibool_superbrick(6, 8) = 18
- ibool_superbrick(7, 8) = 11
- ibool_superbrick(8, 8) = 15
-
- iboun_sb(:,:) = .false.
- iboun_sb(1,2) = .true.
- iboun_sb(1,3) = .true.
- iboun_sb(1,6) = .true.
- iboun_sb(2,2) = .true.
- iboun_sb(2,4) = .true.
- iboun_sb(2,6) = .true.
- iboun_sb(3,1) = .true.
- iboun_sb(3,3) = .true.
- iboun_sb(3,4) = .true.
- iboun_sb(4,1) = .true.
- iboun_sb(4,3) = .true.
- iboun_sb(4,6) = .true.
- iboun_sb(5,2) = .true.
- iboun_sb(5,3) = .true.
- iboun_sb(6,1) = .true.
- iboun_sb(6,4) = .true.
- iboun_sb(6,6) = .true.
- iboun_sb(7,1) = .true.
- iboun_sb(7,3) = .true.
- iboun_sb(8,1) = .true.
- iboun_sb(8,2) = .true.
- iboun_sb(8,3) = .true.
- iboun_sb(8,4) = .true.
- iboun_sb(8,5) = .true.
- END SELECT
-end subroutine define_basic_doubling_brick
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/euler_angles.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/euler_angles.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/euler_angles.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,66 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! compute the Euler angles and the associated rotation matrix
-
- subroutine euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
-
- implicit none
-
- include "constants.h"
-
- double precision rotation_matrix(3,3)
- double precision CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH
-
- double precision alpha,beta,gamma
- double precision sina,cosa,sinb,cosb,sing,cosg
-
-! compute colatitude and longitude and convert to radians
- alpha = CENTER_LONGITUDE_IN_DEGREES * DEGREES_TO_RADIANS
- beta = (90.0d0 - CENTER_LATITUDE_IN_DEGREES) * DEGREES_TO_RADIANS
- gamma = GAMMA_ROTATION_AZIMUTH * DEGREES_TO_RADIANS
-
- sina = dsin(alpha)
- cosa = dcos(alpha)
- sinb = dsin(beta)
- cosb = dcos(beta)
- sing = dsin(gamma)
- cosg = dcos(gamma)
-
-! define rotation matrix
- rotation_matrix(1,1) = cosg*cosb*cosa-sing*sina
- rotation_matrix(1,2) = -sing*cosb*cosa-cosg*sina
- rotation_matrix(1,3) = sinb*cosa
- rotation_matrix(2,1) = cosg*cosb*sina+sing*cosa
- rotation_matrix(2,2) = -sing*cosb*sina+cosg*cosa
- rotation_matrix(2,3) = sinb*sina
- rotation_matrix(3,1) = -cosg*sinb
- rotation_matrix(3,2) = sing*sinb
- rotation_matrix(3,3) = cosb
-
- end subroutine euler_angles
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/exit_mpi.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/exit_mpi.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/exit_mpi.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -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 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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')
- 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/flags.guess
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/flags.guess 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/flags.guess 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,183 +0,0 @@
-#!/bin/sh
-
-# Attempt to guess suitable flags for the Fortran compiler.
-
-# Use AC_CANONICAL_BUILD (and package config.guess, etc.) in the future?
-if test x"$UNAME_MS" = x; then
- UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
- UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
- UNAME_MS="${UNAME_MACHINE}:${UNAME_SYSTEM}"
-fi
-
-case $FC in
- pgf90|*/pgf90)
- #
- # Beowulf Portland pgf90
- #
- if test x"$FLAGS_CHECK" = x; then
- FLAGS_CHECK="-fast -Mnobounds -Mneginfo -Mdclchk -Knoieee" # -mcmodel=medium
- fi
- if test x"$FLAGS_NO_CHECK" = x; then
- FLAGS_NO_CHECK="-fast -Mnobounds -Mneginfo -Mdclchk -Knoieee -Ktrap=none -Minline" # -mcmodel=medium
- fi
- ;;
- ifort|*/ifort)
- #
- # Intel ifort Fortran90 for Linux
- #
- if test x"$FLAGS_CHECK" = x; then
- FLAGS_CHECK="-O3 -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds -align sequence -assume byterecl -i-dynamic -ftrapuv -fpe0 -no-ftz -traceback" # -mcmodel=medium
- fi
- if test x"$FLAGS_NO_CHECK" = x; then
- # standard options
- FLAGS_NO_CHECK="-O3 -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds -align sequence -assume byterecl -i-dynamic -fpe3 -no-ftz" # -mcmodel=medium
- # Pangu at Caltech
- #FLAGS_NO_CHECK = $(IFORT_PROF) -vec_report0 -O2 -static -ip -xP -Wl,--allow-multiple-definition -L $$IFORT_ROOT/lib -limf -lirc
- # debug with range checking
- #FLAGS_NO_CHECK = -O0 -static -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check bounds
- fi
- #MPI_LIBS = -Vaxlib
- ;;
- gfortran|*/gfortran|f95|*/f95)
- #
- # GNU gfortran
- #
- if test x"$FLAGS_NO_CHECK" = x; then
- FLAGS_NO_CHECK="-std=gnu -fimplicit-none -frange-check -O3 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow -fno-trapping-math" # -mcmodel=medium
- fi
- if test x"$FLAGS_CHECK" = x; then
- FLAGS_CHECK="\$(FLAGS_NO_CHECK)" # -fbounds-check
- fi
- ;;
- g95|*/g95)
- #
- # g95 (free f95 compiler from http://www.g95.org)
- #
- if test x"$FLAGS_CHECK" = x; then
- FLAGS_CHECK="-O"
- fi
- if test x"$FLAGS_NO_CHECK" = x; then
- FLAGS_NO_CHECK="-O"
- fi
- ;;
- f90|*/f90)
- case $UNAME_MS in
- i*86:Linux | x86_64:Linux)
- ################ PC Linux #################
- #
- # AbSoft
- #
- if test x"$FLAGS_CHECK" = x; then
- FLAGS_CHECK="-s -O2 -cpu:p7 -v -YDEALLOC=ALL"
- fi
- if test x"$FLAGS_NO_CHECK" = x; then
- FLAGS_NO_CHECK="\$(FLAGS_CHECK)"
- fi
- ;;
- *:IRIX*)
- ################ SGI Irix #################
- if test x"$MPIFC" = x; then
- MPIFC=$FC
- if test x"$MPILIBS" = x; then
- MPILIBS="-lmpi -lfastm -lfpe"
- fi
- fi
- if test x"$FLAGS_CHECK" = x; then
- FLAGS_CHECK="\$(FLAGS_NO_CHECK) -check_bounds"
- fi
- if test x"$FLAGS_NO_CHECK" = x; then
- FLAGS_NO_CHECK="-ansi -u -64 -O3 -OPT:Olimit=0 -OPT:roundoff=3 -OPT:IEEE_arithmetic=3 -r10000 -mips4"
- fi
- ;;
- alpha:OSF1)
- ################## Compaq Dec Alpha #################
- if test x"$MPIFC" = x; then
- MPIFC=$FC
- if test x"$MPILIBS" = x; then
- MPILIBS="-lfmpi -lmpi"
- fi
- fi
- if test x"$FLAGS_CHECK" = x; then
- FLAGS_CHECK="\$(FLAGS_NO_CHECK) -check bounds"
- fi
- if test x"$FLAGS_NO_CHECK" = x; then
- FLAGS_NO_CHECK="-fast -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nounderflow"
- fi
- ;;
- SX-*:SUPER-UX | ES:ESOS)
- ################## Earth Simulator and NEC SX-5 ##################
- if test x"$MPIFC" = x; then
- MPIFC=$FC
- fi
- if test x"$FLAGS_CHECK" = x; then
- FLAGS_CHECK="-C hopt -R2 -Wf\" -L nostdout noinclist mrgmsg noeject -msg b -pvctl loopcnt=14000000 expand=10 fullmsg vecthreshold=20 -s\" -pi auto line=100 exp=swap_all,rank"
- fi
- if test x"$FLAGS_NO_CHECK" = x; then
- FLAGS_NO_CHECK="\$(FLAGS_CHECK)"
- fi
- ;;
- esac
- ;;
- lf95|*/lf95)
- #
- # Lahey f90
- #
- if test x"$FLAGS_CHECK" = x; then
- FLAGS_CHECK="--warn --wo --tpp --f95 --dal -O --chk"
- fi
- if test x"$FLAGS_NO_CHECK" = x; then
- FLAGS_NO_CHECK="--warn --wo --tpp --f95 --dal -O"
- fi
- ;;
- ######## IBM ######
- mpxlf*|*/mpxlf*)
- if test x"$MPIFC" = x; then
- MPIFC=$FC
- fi
- ;;
- *xlf*|*/*xlf*)
- #
- # do NOT remove option -qsave otherwise the IBM compiler allocates the
- # arrays in the stack and the code crashes if the stack size is too
- # small (which is often the case)
- #
- # on IBM with xlf one should also set
- #
- # CC = xlc_r
- # CFLAGS = -O2 -q64
- #
- # or
- #
- # CC = gcc
- # CFLAGS = -O2 -m64
- #
- # for the C compiler when using -q64 for the Fortran compiler
- #
- if test x"$FLAGS_NO_CHECK" = x; then
- FLAGS_NO_CHECK="-O3 -qsave -qstrict -q64 -qtune=auto -qarch=auto -qcache=auto -qfree=f90 -Q -qsuffix=f=f90 -qhalt=w -qlanglvl=2003pure" # -qflttrap=en:ov:zero:inv
- # on MareNostrum at the Barcelona SuperComputing Center (Spain) use
- # -qtune=ppc970 -qarch=ppc64v instead of -qtune=auto -qarch=auto
- fi
- if test x"$FLAGS_CHECK" = x; then
- FLAGS_CHECK="\$(FLAGS_NO_CHECK) -C"
- fi
- ;;
-esac
-
-case $UNAME_MS in
- *:IRIX*)
- ################ SGI Irix #################
- ##
- ## CAUTION: always define setenv TRAP_FPE OFF on SGI before compiling
- ##
- FCENV="TRAP_FPE=OFF"
- ;;
-esac
-
-echo MPIFC=\"$MPIFC\" | sed 's/\$/\\\$/g'
-echo MPILIBS=\"$MPILIBS\" | sed 's/\$/\\\$/g'
-echo FLAGS_CHECK=\"$FLAGS_CHECK\" | sed 's/\$/\\\$/g'
-echo FLAGS_NO_CHECK=\"$FLAGS_NO_CHECK\" | sed 's/\$/\\\$/g'
-echo FCENV=\"$FCENV\" | sed 's/\$/\\\$/g'
-
-# end of file
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_1D_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_1D_buffers.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_1D_buffers.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,482 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_MPI_1D_buffers(myrank,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
- idoubling,xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion,nglob_ori, &
- 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)
-
-! routine to create the MPI 1D chunk buffers for edges
-
- implicit none
-
- include "constants.h"
-
- 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)
-
-!! DK DK added this for merged version
- integer :: iregion_code
- 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 nspec,myrank,nglob_ori,nglob,ipoin1D,iregion
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
-
- logical iMPIcut_xi(2,nspec)
- logical iMPIcut_eta(2,nspec)
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to create arrays ibool1D
- integer npointot
- logical mask_ibool(npointot)
-
-! global element numbering
- integer ispec
-
-! MPI 1D buffer element numbering
- integer ispeccount,npoin1D,ix,iy,iz
-
-! arrays for sorting routine
- integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
- logical, dimension(:), allocatable :: ifseg
- double precision, dimension(:), allocatable :: work
- integer, dimension(:), allocatable :: ibool_selected
- double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
-
-! allocate arrays for message buffers with maximum size
-! define maximum size for message buffers
- if (PERFORM_CUTHILL_MCKEE) then
- allocate(ibool_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- allocate(xstore_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- allocate(ystore_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- allocate(zstore_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- allocate(ind(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- allocate(ninseg(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- allocate(iglob(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- allocate(locval(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- allocate(ifseg(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- allocate(iwork(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- allocate(work(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
- endif
-
-! write the MPI buffers for the left and right edges of the slice
-! and the position of the points to check that the buffers are fine
-
-! *****************************************************************
-! ****************** generate for eta = eta_min *******************
-! *****************************************************************
-
-! determine if the element falls on the left MPI cut plane
-
-! global point number and coordinates left MPI 1D buffer
-!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! nb of global points shared with the other slice
- npoin1D = 0
-
-! nb of elements in this 1D buffer
- ispeccount=0
-
- do ispec=1,nspec
- ! remove central cube for chunk buffers
-!! DK DK added this for merged version because array idoubling is not allocated in outer core
- 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
- ! corner detection here
- if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(1,ispec)) then
- ispeccount=ispeccount+1
- ! loop on all the points
- ix = 1
- iy = 1
- do iz=1,NGLLZ
- ! select point, if not already selected
- if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
-!! DK DK added this for merged version
- if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
- if (PERFORM_CUTHILL_MCKEE) then
- ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
- xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
- ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
- zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
- else
-!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
-!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
-!! DK DK added this for merged
- ibool1D_leftxi_lefteta(npoin1D) = ibool(ix,iy,iz,ispec)
- xread1D_leftxi_lefteta(npoin1D) = xstore(ix,iy,iz,ispec)
- yread1D_leftxi_lefteta(npoin1D) = ystore(ix,iy,iz,ispec)
- zread1D_leftxi_lefteta(npoin1D) = zstore(ix,iy,iz,ispec)
- endif
- endif
- enddo
- endif
- enddo
-
- nglob=nglob_ori
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
- ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-!! DK DK added this for merged version
- if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
-
- do ipoin1D=1,npoin1D
-!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
-!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
-!! DK DK added this for merged
- ibool1D_leftxi_lefteta(ipoin1D) = ibool_selected(ipoin1D)
- xread1D_leftxi_lefteta(ipoin1D) = xstore_selected(ipoin1D)
- yread1D_leftxi_lefteta(ipoin1D) = ystore_selected(ipoin1D)
- zread1D_leftxi_lefteta(ipoin1D) = zstore_selected(ipoin1D)
- enddo
- endif
-
-! put flag to indicate end of the list of points
-!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
-!! DK DK suppressed merged write(10,*) npoin1D
-
-!! DK DK suppressed merged close(10)
-
-! compare number of edge elements detected to analytical value
- if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,1) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,1)) &
- call exit_MPI(myrank,'error MPI 1D buffer detection in xi=left')
-
-! determine if the element falls on the right MPI cut plane
-
-! global point number and coordinates right MPI 1D buffer
-!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! nb of global points shared with the other slice
- npoin1D = 0
-
-! nb of elements in this 1D buffer
- ispeccount=0
- do ispec=1,nspec
- ! remove central cube for chunk buffers
-!! DK DK added this for merged version because array idoubling is not allocated in outer core
- 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
- ! corner detection here
- if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(1,ispec)) then
- ispeccount=ispeccount+1
- ! loop on all the points
- ix = NGLLX
- iy = 1
- do iz=1,NGLLZ
- ! select point, if not already selected
- if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
-!! DK DK added this for merged version
- if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
- if (PERFORM_CUTHILL_MCKEE) then
- ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
- xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
- ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
- zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
- else
-!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
-!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
-!! DK DK added this for merged
- ibool1D_rightxi_lefteta(npoin1D) = ibool(ix,iy,iz,ispec)
- xread1D_rightxi_lefteta(npoin1D) = xstore(ix,iy,iz,ispec)
- yread1D_rightxi_lefteta(npoin1D) = ystore(ix,iy,iz,ispec)
- zread1D_rightxi_lefteta(npoin1D) = zstore(ix,iy,iz,ispec)
- endif
- endif
- enddo
- endif
- enddo
-
- nglob=nglob_ori
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
- ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-!! DK DK added this for merged version
- if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
-
- do ipoin1D=1,npoin1D
-!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
-!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
-!! DK DK added this for merged
- ibool1D_rightxi_lefteta(ipoin1D) = ibool_selected(ipoin1D)
- xread1D_rightxi_lefteta(ipoin1D) = xstore_selected(ipoin1D)
- yread1D_rightxi_lefteta(ipoin1D) = ystore_selected(ipoin1D)
- zread1D_rightxi_lefteta(ipoin1D) = zstore_selected(ipoin1D)
- enddo
- endif
-
-! put flag to indicate end of the list of points
-!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
-!! DK DK suppressed merged write(10,*) npoin1D
-
-!! DK DK suppressed merged close(10)
-
-! compare number of edge elements and points detected to analytical value
- if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,2) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,2)) &
- call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right')
-
-! *****************************************************************
-! ****************** generate for eta = eta_max *******************
-! *****************************************************************
-
-! determine if the element falls on the left MPI cut plane
-
-! global point number and coordinates left MPI 1D buffer
-!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! nb of global points shared with the other slice
- npoin1D = 0
-
-! nb of elements in this 1D buffer
- ispeccount=0
-
- do ispec=1,nspec
-
-! remove central cube for chunk buffers
-!! DK DK added this for merged version because array idoubling is not allocated in outer core
- 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
-
-! corner detection here
- if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(2,ispec)) then
-
- ispeccount=ispeccount+1
-
-! loop on all the points
- ix = 1
- iy = NGLLY
- do iz=1,NGLLZ
-
- ! select point, if not already selected
- if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
-!! DK DK added this for merged version
- if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
- if (PERFORM_CUTHILL_MCKEE) then
- ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
- xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
- ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
- zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
- else
-!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
-!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
-!! DK DK added this for merged
- ibool1D_leftxi_righteta(npoin1D) = ibool(ix,iy,iz,ispec)
- xread1D_leftxi_righteta(npoin1D) = xstore(ix,iy,iz,ispec)
- yread1D_leftxi_righteta(npoin1D) = ystore(ix,iy,iz,ispec)
- zread1D_leftxi_righteta(npoin1D) = zstore(ix,iy,iz,ispec)
- endif
- endif
- enddo
- endif
- enddo
-
- nglob=nglob_ori
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
- ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-!! DK DK added this for merged version
- if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
-
- do ipoin1D=1,npoin1D
-!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
-!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
-!! DK DK added this for merged
- ibool1D_leftxi_righteta(ipoin1D) = ibool_selected(ipoin1D)
- xread1D_leftxi_righteta(ipoin1D) = xstore_selected(ipoin1D)
- yread1D_leftxi_righteta(ipoin1D) = ystore_selected(ipoin1D)
- zread1D_leftxi_righteta(ipoin1D) = zstore_selected(ipoin1D)
- enddo
- endif
-
-! put flag to indicate end of the list of points
-!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
-!! DK DK suppressed merged write(10,*) npoin1D
-
-!! DK DK suppressed merged close(10)
-
-! compare number of edge elements detected to analytical value
- if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,4) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,4)) &
- call exit_MPI(myrank,'error MPI 1D buffer detection in xi=left')
-
-! determine if the element falls on the right MPI cut plane
-
-! global point number and coordinates right MPI 1D buffer
-!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! nb of global points shared with the other slice
- npoin1D = 0
-
-! nb of elements in this 1D buffer
- ispeccount=0
-
- do ispec=1,nspec
-
-! remove central cube for chunk buffers
-!! DK DK added this for merged version because array idoubling is not allocated in outer core
- 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
-
-! corner detection here
- if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(2,ispec)) then
-
- ispeccount=ispeccount+1
-
-! loop on all the points
- ix = NGLLX
- iy = NGLLY
- do iz=1,NGLLZ
-
- ! select point, if not already selected
- if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
-!! DK DK added this for merged version
- if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
- if (PERFORM_CUTHILL_MCKEE) then
- ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
- xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
- ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
- zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
- else
-!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
-!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
- ibool1D_rightxi_righteta(npoin1D) = ibool(ix,iy,iz,ispec)
- xread1D_rightxi_righteta(npoin1D) = xstore(ix,iy,iz,ispec)
- yread1D_rightxi_righteta(npoin1D) = ystore(ix,iy,iz,ispec)
- zread1D_rightxi_righteta(npoin1D) = zstore(ix,iy,iz,ispec)
- endif
- endif
- enddo
- endif
- enddo
-
- nglob=nglob_ori
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
- ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-!! DK DK added this for merged version
- if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
-
- do ipoin1D=1,npoin1D
-!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
-!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
-!! DK DK added this for merged
- ibool1D_rightxi_righteta(ipoin1D) = ibool_selected(ipoin1D)
- xread1D_rightxi_righteta(ipoin1D) = xstore_selected(ipoin1D)
- yread1D_rightxi_righteta(ipoin1D) = ystore_selected(ipoin1D)
- zread1D_rightxi_righteta(ipoin1D) = zstore_selected(ipoin1D)
- enddo
- endif
-
-! put flag to indicate end of the list of points
-!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
-!! DK DK suppressed merged write(10,*) npoin1D
-
-!! DK DK suppressed merged close(10)
-
-! compare number of edge elements and points detected to analytical value
- if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,3) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,3)) &
- call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right')
-
- if (PERFORM_CUTHILL_MCKEE) then
- deallocate(ibool_selected)
- deallocate(xstore_selected)
- deallocate(ystore_selected)
- deallocate(zstore_selected)
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iglob)
- deallocate(locval)
- deallocate(ifseg)
- deallocate(iwork)
- deallocate(work)
- endif
-
- end subroutine get_MPI_1D_buffers
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_eta.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_eta.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_eta.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,267 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_MPI_cutplanes_eta(myrank,nspec,iMPIcut_eta,ibool, &
- xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC2D_XI_FACE,iregion,NGLOB2DMAX_XY,nglob_ori,iboolleft_eta,iboolright_eta,NGLOB2DMAX_YMIN_YMAX,npoin2D_eta)
-
-! this routine detects cut planes along eta
-! In principle the left cut plane of the first slice
-! and the right cut plane of the last slice are not used
-! in the solver except if we want to have periodic conditions
-
- implicit none
-
- include "constants.h"
-
- integer :: NGLOB2DMAX_YMIN_YMAX
- integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
-
- integer nspec,myrank,nglob_ori,nglob,ipoin2D,NGLOB2DMAX_XY,iregion
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE
-
- logical iMPIcut_eta(2,nspec)
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to create arrays iboolleft_eta and iboolright_eta
- integer npointot
- logical mask_ibool(npointot)
-
-! global element numbering
- integer ispec
-
-! MPI cut-plane element numbering
- integer ispecc1,ispecc2,npoin2D_eta,ix,iy,iz
- integer nspec2Dtheor
-
-! arrays for sorting routine
- integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
- logical, dimension(:), allocatable :: ifseg
- double precision, dimension(:), allocatable :: work
- integer, dimension(:), allocatable :: ibool_selected
- double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
-
-
-! allocate arrays for message buffers with maximum size
-! define maximum size for message buffers
- if (PERFORM_CUTHILL_MCKEE) then
- allocate(ibool_selected(NGLOB2DMAX_XY))
- allocate(xstore_selected(NGLOB2DMAX_XY))
- allocate(ystore_selected(NGLOB2DMAX_XY))
- allocate(zstore_selected(NGLOB2DMAX_XY))
- allocate(ind(NGLOB2DMAX_XY))
- allocate(ninseg(NGLOB2DMAX_XY))
- allocate(iglob(NGLOB2DMAX_XY))
- allocate(locval(NGLOB2DMAX_XY))
- allocate(ifseg(NGLOB2DMAX_XY))
- allocate(iwork(NGLOB2DMAX_XY))
- allocate(work(NGLOB2DMAX_XY))
- endif
-
-! theoretical number of surface elements in the buffers
-! cut planes along eta=constant correspond to XI faces
- nspec2Dtheor = NSPEC2D_XI_FACE(iregion,1)
-
-! write the MPI buffers for the left and right edges of the slice
-! and the position of the points to check that the buffers are fine
-
-!
-! determine if the element falls on the left MPI cut plane
-!
-
-! global point number and coordinates left MPI cut-plane
-!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_eta.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! nb of global points shared with the other slice
- npoin2D_eta = 0
-
-! nb of elements in this cut-plane
- ispecc1=0
-
- do ispec=1,nspec
- if(iMPIcut_eta(1,ispec)) then
- ispecc1=ispecc1+1
- ! loop on all the points in that 2-D element, including edges
- iy = 1
- do ix=1,NGLLX
- do iz=1,NGLLZ
- ! select point, if not already selected
- if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_eta = npoin2D_eta + 1
-!! DK DK added this for merged
- if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
- if (PERFORM_CUTHILL_MCKEE) then
- ibool_selected(npoin2D_eta) = ibool(ix,iy,iz,ispec)
- xstore_selected(npoin2D_eta) = xstore(ix,iy,iz,ispec)
- ystore_selected(npoin2D_eta) = ystore(ix,iy,iz,ispec)
- zstore_selected(npoin2D_eta) = zstore(ix,iy,iz,ispec)
- else
-!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
-!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
-!! DK DK added this for merged
-!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
-!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
- iboolleft_eta(npoin2D_eta) = ibool(ix,iy,iz,ispec)
- endif
- endif
- enddo
- enddo
- endif
- enddo
-
- nglob=nglob_ori
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_array_coordinates(npoin2D_eta,xstore_selected,ystore_selected,zstore_selected, &
- ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-!! DK DK added this for merged
- if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
-
- do ipoin2D=1,npoin2D_eta
-!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
-!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
-!! DK DK added this for merged
-!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
-!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
- iboolleft_eta(ipoin2D) = ibool_selected(ipoin2D)
- enddo
- endif
-
-! put flag to indicate end of the list of points
-!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
-!! DK DK suppressed merged write(10,*) npoin2D_eta
-
-!! DK DK suppressed merged close(10)
-
-! compare number of surface elements detected to analytical value
- if(ispecc1 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=left')
-
-!
-! determine if the element falls on the right MPI cut plane
-!
- nspec2Dtheor = NSPEC2D_XI_FACE(iregion,2)
-
-! global point number and coordinates right MPI cut-plane
-!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! nb of global points shared with the other slice
- npoin2D_eta = 0
-
-! nb of elements in this cut-plane
- ispecc2=0
-
- do ispec=1,nspec
- if(iMPIcut_eta(2,ispec)) then
- ispecc2=ispecc2+1
- ! loop on all the points in that 2-D element, including edges
- iy = NGLLY
- do ix=1,NGLLX
- do iz=1,NGLLZ
- ! select point, if not already selected
- if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_eta = npoin2D_eta + 1
-!! DK DK added this for merged
- if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
- if (PERFORM_CUTHILL_MCKEE) then
- ibool_selected(npoin2D_eta) = ibool(ix,iy,iz,ispec)
- xstore_selected(npoin2D_eta) = xstore(ix,iy,iz,ispec)
- ystore_selected(npoin2D_eta) = ystore(ix,iy,iz,ispec)
- zstore_selected(npoin2D_eta) = zstore(ix,iy,iz,ispec)
- else
-!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
-!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
-!! DK DK added this for merged
-!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
-!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
- iboolright_eta(npoin2D_eta) = ibool(ix,iy,iz,ispec)
- endif
- endif
- enddo
- enddo
- endif
- enddo
-
- nglob=nglob_ori
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_array_coordinates(npoin2D_eta,xstore_selected,ystore_selected,zstore_selected, &
- ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-!! DK DK added this for merged
- if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
-
- do ipoin2D=1,npoin2D_eta
-!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
-!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
-!! DK DK added this for merged
-!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
-!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
- iboolright_eta(ipoin2D) = ibool_selected(ipoin2D)
- enddo
- endif
-
-! put flag to indicate end of the list of points
-!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
-!! DK DK suppressed merged write(10,*) npoin2D_eta
-
-!! DK DK suppressed merged close(10)
-
-! compare number of surface elements detected to analytical value
- if(ispecc2 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=right')
-
- if (PERFORM_CUTHILL_MCKEE) then
- deallocate(ibool_selected)
- deallocate(xstore_selected)
- deallocate(ystore_selected)
- deallocate(zstore_selected)
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iglob)
- deallocate(locval)
- deallocate(ifseg)
- deallocate(iwork)
- deallocate(work)
- endif
-
- end subroutine get_MPI_cutplanes_eta
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_xi.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_xi.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_xi.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,266 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_MPI_cutplanes_xi(myrank,nspec,iMPIcut_xi,ibool, &
- xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC2D_ETA_FACE,iregion,NGLOB2DMAX_XY,nglob_ori,iboolleft_xi,iboolright_xi,NGLOB2DMAX_XMIN_XMAX,npoin2D_xi)
-
-! this routine detects cut planes along xi
-! In principle the left cut plane of the first slice
-! and the right cut plane of the last slice are not used
-! in the solver except if we want to have periodic conditions
-
- implicit none
-
- include "constants.h"
-
- integer :: NGLOB2DMAX_XMIN_XMAX
- integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
-
- integer nspec,myrank,nglob_ori,nglob,ipoin2D,iregion
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_ETA_FACE
-
- logical iMPIcut_xi(2,nspec)
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to create arrays iboolleft_xi and iboolright_xi
- integer npointot
- logical mask_ibool(npointot)
-
-! global element numbering
- integer ispec
-
-! MPI cut-plane element numbering
- integer ispecc1,ispecc2,npoin2D_xi,ix,iy,iz
- integer nspec2Dtheor
-
- character(len=150) errmsg
-
-! arrays for sorting routine
- integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
- logical, dimension(:), allocatable :: ifseg
- double precision, dimension(:), allocatable :: work
- integer NGLOB2DMAX_XY
- integer, dimension(:), allocatable :: ibool_selected
- double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
-
-! allocate arrays for message buffers with maximum size
-! define maximum size for message buffers
- if (PERFORM_CUTHILL_MCKEE) then
- allocate(ibool_selected(NGLOB2DMAX_XY))
- allocate(xstore_selected(NGLOB2DMAX_XY))
- allocate(ystore_selected(NGLOB2DMAX_XY))
- allocate(zstore_selected(NGLOB2DMAX_XY))
- allocate(ind(NGLOB2DMAX_XY))
- allocate(ninseg(NGLOB2DMAX_XY))
- allocate(iglob(NGLOB2DMAX_XY))
- allocate(locval(NGLOB2DMAX_XY))
- allocate(ifseg(NGLOB2DMAX_XY))
- allocate(iwork(NGLOB2DMAX_XY))
- allocate(work(NGLOB2DMAX_XY))
- endif
-
-
-! theoretical number of surface elements in the buffers
-! cut planes along xi=constant correspond to ETA faces
- nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,1)
-! write the MPI buffers for the left and right edges of the slice
-! and the position of the points to check that the buffers are fine
-
-!
-! determine if the element falls on the left MPI cut plane
-!
-
-! global point number and coordinates left MPI cut-plane
-!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_xi.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! nb of global points shared with the other slice
- npoin2D_xi = 0
-
-! nb of elements in this cut-plane
- ispecc1=0
-
- do ispec=1,nspec
- if(iMPIcut_xi(1,ispec)) then
- ispecc1=ispecc1+1
- ! loop on all the points in that 2-D element, including edges
- ix = 1
- do iy=1,NGLLY
- do iz=1,NGLLZ
- ! select point, if not already selected
- if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_xi = npoin2D_xi + 1
-!! DK DK added this for merged
- if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
- if (PERFORM_CUTHILL_MCKEE) then
- ibool_selected(npoin2D_xi) = ibool(ix,iy,iz,ispec)
- xstore_selected(npoin2D_xi) = xstore(ix,iy,iz,ispec)
- ystore_selected(npoin2D_xi) = ystore(ix,iy,iz,ispec)
- zstore_selected(npoin2D_xi) = zstore(ix,iy,iz,ispec)
- else
-!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
-!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
-!! DK DK added this for merged
- iboolleft_xi(npoin2D_xi) = ibool(ix,iy,iz,ispec)
- endif
- endif
- enddo
- enddo
- endif
- enddo
-
- nglob=nglob_ori
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_array_coordinates(npoin2D_xi,xstore_selected,ystore_selected,zstore_selected, &
- ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-!! DK DK added this for merged
- if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
-
- do ipoin2D=1,npoin2D_xi
-!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
-!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
-!! DK DK added this for merged
-!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
-!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
- iboolleft_xi(ipoin2D) = ibool_selected(ipoin2D)
- enddo
- endif
-
-! put flag to indicate end of the list of points
-!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
-!! DK DK suppressed merged write(10,*) npoin2D_xi
-
-!! DK DK suppressed merged close(10)
-
-! compare number of surface elements detected to analytical value
- if(ispecc1 /= nspec2Dtheor) then
- write(errmsg,*) 'error MPI cut-planes detection in xi=left T=',nspec2Dtheor,' C=',ispecc1
- call exit_MPI(myrank,errmsg)
- endif
-!
-! determine if the element falls on the right MPI cut plane
-!
- nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,2)
-
-! global point number and coordinates right MPI cut-plane
-!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolright_xi.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! nb of global points shared with the other slice
- npoin2D_xi = 0
-
-! nb of elements in this cut-plane
- ispecc2=0
-
- do ispec=1,nspec
- if(iMPIcut_xi(2,ispec)) then
- ispecc2=ispecc2+1
- ! loop on all the points in that 2-D element, including edges
- ix = NGLLX
- do iy=1,NGLLY
- do iz=1,NGLLZ
- ! select point, if not already selected
- if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_xi = npoin2D_xi + 1
-!! DK DK added this for merged
- if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
- if (PERFORM_CUTHILL_MCKEE) then
- ibool_selected(npoin2D_xi) = ibool(ix,iy,iz,ispec)
- xstore_selected(npoin2D_xi) = xstore(ix,iy,iz,ispec)
- ystore_selected(npoin2D_xi) = ystore(ix,iy,iz,ispec)
- zstore_selected(npoin2D_xi) = zstore(ix,iy,iz,ispec)
- else
-!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
-!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
- iboolright_xi(npoin2D_xi) = ibool(ix,iy,iz,ispec)
- endif
- endif
- enddo
- enddo
- endif
- enddo
-
- nglob=nglob_ori
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_array_coordinates(npoin2D_xi,xstore_selected,ystore_selected,zstore_selected, &
- ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-!! DK DK added this for merged
- if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
-
- do ipoin2D=1,npoin2D_xi
-!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
-!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
- iboolright_xi(ipoin2D) = ibool_selected(ipoin2D)
- enddo
- endif
-
-! put flag to indicate end of the list of points
-!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
-!! DK DK suppressed merged write(10,*) npoin2D_xi
-
-!! DK DK suppressed merged close(10)
-
-! compare number of surface elements detected to analytical value
- if(ispecc2 /= nspec2Dtheor) then
- write(errmsg,*) 'error MPI cut-planes detection in xi=right T=',nspec2Dtheor,' C=',ispecc2
- call exit_MPI(myrank,errmsg)
- endif
-
- if (PERFORM_CUTHILL_MCKEE) then
- deallocate(ibool_selected)
- deallocate(xstore_selected)
- deallocate(ystore_selected)
- deallocate(zstore_selected)
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iglob)
- deallocate(locval)
- deallocate(ifseg)
- deallocate(iwork)
- deallocate(work)
- endif
-
- end subroutine get_MPI_cutplanes_xi
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_cmt.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_cmt.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_cmt.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,189 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,NSOURCES)
-
- implicit none
-
- include "constants.h"
-
-!--- input or output arguments of the subroutine below
-
- integer, intent(in) :: NSOURCES
- double precision, intent(in) :: DT
-
- integer, intent(out) :: yr,jda,ho,mi
- double precision, intent(out) :: sec
- double precision, dimension(NSOURCES), intent(out) :: t_cmt,hdur,lat,long,depth
- double precision, dimension(6,NSOURCES), intent(out) :: moment_tensor
-
-!--- local variables below
-
- integer mo,da,julian_day,isource
- double precision scaleM
- character(len=5) datasource
- character(len=150) string, CMTSOLUTION
-
-!
-!---- read hypocenter info
-!
- call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
-
- open(unit=1,file=CMTSOLUTION,status='old',action='read')
-
-! read source number isource
- do isource=1,NSOURCES
-
-! read header with event information
- read(1,"(a4,i5,i3,i3,i3,i3,f6.2)") datasource,yr,mo,da,ho,mi,sec
- jda=julian_day(yr,mo,da)
-
-! ignore line with event name
- read(1,"(a)") string
-
-! read time shift
- read(1,"(a)") string
- read(string(12:len_trim(string)),*) t_cmt(isource)
-
-! read half duration
- read(1,"(a)") string
- read(string(15:len_trim(string)),*) hdur(isource)
-
-! read latitude
- read(1,"(a)") string
- read(string(10:len_trim(string)),*) lat(isource)
-
-! read longitude
- read(1,"(a)") string
- read(string(11:len_trim(string)),*) long(isource)
-
-! read depth
- read(1,"(a)") string
- read(string(7:len_trim(string)),*) depth(isource)
-
-! read Mrr
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(1,isource)
-
-! read Mtt
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(2,isource)
-
-! read Mpp
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(3,isource)
-
-! read Mrt
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(4,isource)
-
-! read Mrp
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(5,isource)
-
-! read Mtp
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(6,isource)
-
-! null half-duration indicates a Heaviside
-! replace with very short error function
- if(hdur(isource) < 5. * DT) hdur(isource) = 5. * DT
-
- enddo
-
- close(1)
-
-!
-! scale and non-dimensionalize the moment tensor
-! CMTSOLUTION file values are in dyne.cm
-! 1 dyne is 1 gram * 1 cm / (1 second)^2
-! 1 Newton is 1 kg * 1 m / (1 second)^2
-! thus 1 Newton = 100,000 dynes
-! therefore 1 dyne.cm = 1e-7 Newton.m
-!
- scaleM = 1.d7 * RHOAV * (R_EARTH**5) * PI*GRAV*RHOAV
- moment_tensor(:,:) = moment_tensor(:,:) / scaleM
-
- end subroutine get_cmt
-
-! ------------------------------------------------------------------
-
- integer function julian_day(yr,mo,da)
-
- implicit none
-
- integer yr,mo,da
-
- integer mon(12)
- integer lpyr
- data mon /0,31,59,90,120,151,181,212,243,273,304,334/
-
- julian_day = da + mon(mo)
- if(mo>2) julian_day = julian_day + lpyr(yr)
-
- end function julian_day
-
-! ------------------------------------------------------------------
-
- integer function lpyr(yr)
-
- implicit none
-
- integer yr
-!
-!---- returns 1 if leap year
-!
- lpyr=0
- if(mod(yr,400) == 0) then
- lpyr=1
- else if(mod(yr,4) == 0) then
- lpyr=1
- if(mod(yr,100) == 0) lpyr=0
- endif
-
- end function lpyr
-
-! ------------------------------------------------------------------
-
-! function to determine if year is a leap year
- logical function is_leap_year(yr)
-
- implicit none
-
- integer yr
-
- integer, external :: lpyr
-
-!---- function lpyr above returns 1 if leap year
- if(lpyr(yr) == 1) then
- is_leap_year = .true.
- else
- is_leap_year = .false.
- endif
-
- end function is_leap_year
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_ellipticity.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_ellipticity.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_ellipticity.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,65 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2)
-
- implicit none
-
- include "constants.h"
-
- integer nspl
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
- double precision rspl(NR),espl(NR),espl2(NR)
-
- integer ia
-
- double precision ell
- double precision r,theta,phi,factor
- double precision cost,p20
-
- do ia=1,NGNOD
-
- call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
-
- cost=dcos(theta)
- p20=0.5d0*(3.0d0*cost*cost-1.0d0)
-
-! get ellipticity using spline evaluation
- call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
-
- factor=ONE-(TWO/3.0d0)*ell*p20
-
- xelm(ia)=xelm(ia)*factor
- yelm(ia)=yelm(ia)*factor
- zelm(ia)=zelm(ia)*factor
-
- enddo
-
- end subroutine get_ellipticity
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_event_info.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_event_info.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_event_info.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -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 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_global.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_global.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,234 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_global(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot)
-
-! this routine MUST be in double precision to avoid sensitivity
-! to roundoff errors in the coordinates of the points
-
-! non-structured global numbering software provided by Paul F. Fischer
-
-! leave sorting subroutines in same source file to allow for inlining
-
- implicit none
-
- include "constants.h"
-
-! parameters
- integer, intent(in) :: npointot,nspec
- double precision, intent(in) :: xp(npointot),yp(npointot),zp(npointot)
-
- integer, intent(out) :: iglob(npointot),loc(npointot)
- logical, intent(out) :: ifseg(npointot)
- integer, intent(out) :: nglob
-
-! variables
- integer ispec,i,j
- integer ieoff,ilocnum,nseg,ioff,iseg,ig
-
- integer, dimension(:), allocatable :: ind,ninseg,iwork
- double precision, dimension(:), allocatable :: work
-
-! dynamically allocate arrays
- allocate(ind(npointot))
- allocate(ninseg(npointot))
- allocate(iwork(npointot))
- allocate(work(npointot))
-
-! establish initial pointers
- do ispec=1,nspec
- ieoff=NGLLX * NGLLY * NGLLZ * (ispec-1)
- do ilocnum=1,NGLLX * NGLLY * NGLLZ
- loc(ilocnum+ieoff)=ilocnum+ieoff
- enddo
- enddo
-
- ifseg(:)=.false.
-
- nseg=1
- ifseg(1)=.true.
- ninseg(1)=npointot
-
-do j=1,NDIM
-
- ! sort within each segment
- ioff=1
- do iseg=1,nseg
- if(j == 1) then
- call rank(xp(ioff),ind,ninseg(iseg))
- else if(j == 2) then
- call rank(yp(ioff),ind,ninseg(iseg))
- else
- call rank(zp(ioff),ind,ninseg(iseg))
- endif
- call swap_all(loc(ioff),xp(ioff),yp(ioff),zp(ioff),iwork,work,ind,ninseg(iseg))
- ioff=ioff+ninseg(iseg)
- enddo
-
-! check for jumps in current coordinate
-! compare the coordinates of the points within a small tolerance
- if(j == 1) then
- do i=2,npointot
- if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
- enddo
- else if(j == 2) then
- do i=2,npointot
- if(dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
- enddo
- else
- do i=2,npointot
- if(dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
- enddo
- endif
-
-! count up number of different segments
- nseg=0
- do i=1,npointot
- if(ifseg(i)) then
- nseg=nseg+1
- ninseg(nseg)=1
- else
- ninseg(nseg)=ninseg(nseg)+1
- endif
- enddo
-enddo
-
-! assign global node numbers (now sorted lexicographically)
- ig=0
- do i=1,npointot
- if(ifseg(i)) ig=ig+1
- iglob(loc(i))=ig
- enddo
-
- nglob=ig
-
-! deallocate arrays
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iwork)
- deallocate(work)
-
- end subroutine get_global
-
-! -----------------------------------
-
-! sorting routines put in same file to allow for inlining
-
- subroutine rank(A,IND,N)
-!
-! Use Heap Sort (Numerical Recipes)
-!
- implicit none
-
- integer n
- double precision A(n)
- integer IND(n)
-
- integer i,j,l,ir,indx
- double precision q
-
- do j=1,n
- IND(j)=j
- enddo
-
- if (n == 1) return
-
- L=n/2+1
- ir=n
- 100 CONTINUE
- IF (l>1) THEN
- l=l-1
- indx=ind(l)
- q=a(indx)
- ELSE
- indx=ind(ir)
- q=a(indx)
- ind(ir)=ind(1)
- ir=ir-1
- if (ir == 1) then
- ind(1)=indx
- return
- endif
- ENDIF
- i=l
- j=l+l
- 200 CONTINUE
- IF (J <= IR) THEN
- IF (J<IR) THEN
- IF ( A(IND(j))<A(IND(j+1)) ) j=j+1
- ENDIF
- IF (q<A(IND(j))) THEN
- IND(I)=IND(J)
- I=J
- J=J+J
- ELSE
- J=IR+1
- ENDIF
- goto 200
- ENDIF
- IND(I)=INDX
- goto 100
- end subroutine rank
-
-! ------------------------------------------------------------------
-
- subroutine swap_all(IA,A,B,C,IW,W,ind,n)
-!
-! swap arrays IA, A, B and C according to addressing in array IND
-!
- implicit none
-
- integer n
-
- integer IND(n)
- integer IA(n),IW(n)
- double precision A(n),B(n),C(n),W(n)
-
- integer i
-
- IW(:) = IA(:)
- W(:) = A(:)
-
- do i=1,n
- IA(i)=IW(ind(i))
- A(i)=W(ind(i))
- enddo
-
- W(:) = B(:)
-
- do i=1,n
- B(i)=W(ind(i))
- enddo
-
- W(:) = C(:)
-
- do i=1,n
- C(i)=W(ind(i))
- enddo
-
- end subroutine swap_all
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_jacobian_boundaries.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_jacobian_boundaries.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_jacobian_boundaries.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -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 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 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)
-
- implicit none
-
- include "constants.h"
-
- integer nspec,myrank
- integer NSPEC2D_BOTTOM,NSPEC2D_TOP,NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
-
- 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 ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP)
-
- logical iboun(6,nspec)
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) 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)
-
- 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)
-
-! global element numbering
- integer ispec
-
-! counters to keep track of number of elements on each of the boundaries
- integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5,ispecb6
-
- double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
-
-! check that the parameter file is correct
- if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes')
- if(NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes')
-
- ispecb1 = 0
- ispecb2 = 0
- ispecb3 = 0
- ispecb4 = 0
- ispecb5 = 0
- ispecb6 = 0
-
- do ispec=1,nspec
-
-! determine if the element falls on a boundary
-
-! on boundary: xmin
-
- if(iboun(1,ispec)) then
-
- ispecb1=ispecb1+1
- ibelm_xmin(ispecb1)=ispec
-
-! specify the 9 nodes for the 2-D boundary element
- xelm(1)=xstore(1,1,1,ispec)
- yelm(1)=ystore(1,1,1,ispec)
- zelm(1)=zstore(1,1,1,ispec)
- xelm(2)=xstore(1,NGLLY,1,ispec)
- yelm(2)=ystore(1,NGLLY,1,ispec)
- zelm(2)=zstore(1,NGLLY,1,ispec)
- xelm(3)=xstore(1,NGLLY,NGLLZ,ispec)
- yelm(3)=ystore(1,NGLLY,NGLLZ,ispec)
- zelm(3)=zstore(1,NGLLY,NGLLZ,ispec)
- xelm(4)=xstore(1,1,NGLLZ,ispec)
- yelm(4)=ystore(1,1,NGLLZ,ispec)
- zelm(4)=zstore(1,1,NGLLZ,ispec)
- xelm(5)=xstore(1,(NGLLY+1)/2,1,ispec)
- yelm(5)=ystore(1,(NGLLY+1)/2,1,ispec)
- zelm(5)=zstore(1,(NGLLY+1)/2,1,ispec)
- xelm(6)=xstore(1,NGLLY,(NGLLZ+1)/2,ispec)
- yelm(6)=ystore(1,NGLLY,(NGLLZ+1)/2,ispec)
- zelm(6)=zstore(1,NGLLY,(NGLLZ+1)/2,ispec)
- xelm(7)=xstore(1,(NGLLY+1)/2,NGLLZ,ispec)
- yelm(7)=ystore(1,(NGLLY+1)/2,NGLLZ,ispec)
- zelm(7)=zstore(1,(NGLLY+1)/2,NGLLZ,ispec)
- xelm(8)=xstore(1,1,(NGLLZ+1)/2,ispec)
- yelm(8)=ystore(1,1,(NGLLZ+1)/2,ispec)
- zelm(8)=zstore(1,1,(NGLLZ+1)/2,ispec)
- xelm(9)=xstore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
- yelm(9)=ystore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
- zelm(9)=zstore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
-
- call compute_jacobian_2D(myrank,ispecb1,xelm,yelm,zelm,dershape2D_x, &
- jacobian2D_xmin,normal_xmin,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
-
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_arrays_for_cuthill (ispecb1,xstore,ystore,zstore,ibelm_xmin,normal_xmin,&
- jacobian2D_xmin,NSPEC2DMAX_XMIN_XMAX,NGLLY,NGLLZ,nspec)
- endif
- endif
-
-! on boundary: xmax
-
- if(iboun(2,ispec)) then
-
- ispecb2=ispecb2+1
- ibelm_xmax(ispecb2)=ispec
-
-! specify the 9 nodes for the 2-D boundary element
- xelm(1)=xstore(NGLLX,1,1,ispec)
- yelm(1)=ystore(NGLLX,1,1,ispec)
- zelm(1)=zstore(NGLLX,1,1,ispec)
- xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
- yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
- zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
- xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
- yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
- zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
- xelm(4)=xstore(NGLLX,1,NGLLZ,ispec)
- yelm(4)=ystore(NGLLX,1,NGLLZ,ispec)
- zelm(4)=zstore(NGLLX,1,NGLLZ,ispec)
- xelm(5)=xstore(NGLLX,(NGLLY+1)/2,1,ispec)
- yelm(5)=ystore(NGLLX,(NGLLY+1)/2,1,ispec)
- zelm(5)=zstore(NGLLX,(NGLLY+1)/2,1,ispec)
- xelm(6)=xstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
- yelm(6)=ystore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
- zelm(6)=zstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
- xelm(7)=xstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
- yelm(7)=ystore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
- zelm(7)=zstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
- xelm(8)=xstore(NGLLX,1,(NGLLZ+1)/2,ispec)
- yelm(8)=ystore(NGLLX,1,(NGLLZ+1)/2,ispec)
- zelm(8)=zstore(NGLLX,1,(NGLLZ+1)/2,ispec)
- xelm(9)=xstore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
- yelm(9)=ystore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
- zelm(9)=zstore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
-
- call compute_jacobian_2D(myrank,ispecb2,xelm,yelm,zelm,dershape2D_x, &
- jacobian2D_xmax,normal_xmax,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
-
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_arrays_for_cuthill (ispecb2,xstore,ystore,zstore,ibelm_xmax,normal_xmax,&
- jacobian2D_xmax,NSPEC2DMAX_XMIN_XMAX,NGLLY,NGLLZ,nspec)
- endif
- endif
-
-! on boundary: ymin
-
- if(iboun(3,ispec)) then
-
- ispecb3=ispecb3+1
- ibelm_ymin(ispecb3)=ispec
-
-! specify the 9 nodes for the 2-D boundary element
- xelm(1)=xstore(1,1,1,ispec)
- yelm(1)=ystore(1,1,1,ispec)
- zelm(1)=zstore(1,1,1,ispec)
- xelm(2)=xstore(NGLLX,1,1,ispec)
- yelm(2)=ystore(NGLLX,1,1,ispec)
- zelm(2)=zstore(NGLLX,1,1,ispec)
- xelm(3)=xstore(NGLLX,1,NGLLZ,ispec)
- yelm(3)=ystore(NGLLX,1,NGLLZ,ispec)
- zelm(3)=zstore(NGLLX,1,NGLLZ,ispec)
- xelm(4)=xstore(1,1,NGLLZ,ispec)
- yelm(4)=ystore(1,1,NGLLZ,ispec)
- zelm(4)=zstore(1,1,NGLLZ,ispec)
- xelm(5)=xstore((NGLLX+1)/2,1,1,ispec)
- yelm(5)=ystore((NGLLX+1)/2,1,1,ispec)
- zelm(5)=zstore((NGLLX+1)/2,1,1,ispec)
- xelm(6)=xstore(NGLLX,1,(NGLLZ+1)/2,ispec)
- yelm(6)=ystore(NGLLX,1,(NGLLZ+1)/2,ispec)
- zelm(6)=zstore(NGLLX,1,(NGLLZ+1)/2,ispec)
- xelm(7)=xstore((NGLLX+1)/2,1,NGLLZ,ispec)
- yelm(7)=ystore((NGLLX+1)/2,1,NGLLZ,ispec)
- zelm(7)=zstore((NGLLX+1)/2,1,NGLLZ,ispec)
- xelm(8)=xstore(1,1,(NGLLZ+1)/2,ispec)
- yelm(8)=ystore(1,1,(NGLLZ+1)/2,ispec)
- zelm(8)=zstore(1,1,(NGLLZ+1)/2,ispec)
- xelm(9)=xstore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
- yelm(9)=ystore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
- zelm(9)=zstore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
-
- call compute_jacobian_2D(myrank,ispecb3,xelm,yelm,zelm,dershape2D_y, &
- jacobian2D_ymin,normal_ymin,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
-
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_arrays_for_cuthill (ispecb3,xstore,ystore,zstore,ibelm_ymin,normal_ymin,&
- jacobian2D_ymin,NSPEC2DMAX_YMIN_YMAX,NGLLX,NGLLZ,nspec)
- endif
- endif
-
-! on boundary: ymax
-
- if(iboun(4,ispec)) then
-
- ispecb4=ispecb4+1
- ibelm_ymax(ispecb4)=ispec
-
-! specify the 9 nodes for the 2-D boundary element
- xelm(1)=xstore(1,NGLLY,1,ispec)
- yelm(1)=ystore(1,NGLLY,1,ispec)
- zelm(1)=zstore(1,NGLLY,1,ispec)
- xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
- yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
- zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
- xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
- yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
- zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
- xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
- yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
- zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
- xelm(5)=xstore((NGLLX+1)/2,NGLLY,1,ispec)
- yelm(5)=ystore((NGLLX+1)/2,NGLLY,1,ispec)
- zelm(5)=zstore((NGLLX+1)/2,NGLLY,1,ispec)
- xelm(6)=xstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
- yelm(6)=ystore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
- zelm(6)=zstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
- xelm(7)=xstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
- yelm(7)=ystore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
- zelm(7)=zstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
- xelm(8)=xstore(1,NGLLY,(NGLLZ+1)/2,ispec)
- yelm(8)=ystore(1,NGLLY,(NGLLZ+1)/2,ispec)
- zelm(8)=zstore(1,NGLLY,(NGLLZ+1)/2,ispec)
- xelm(9)=xstore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
- yelm(9)=ystore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
- zelm(9)=zstore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
-
- call compute_jacobian_2D(myrank,ispecb4,xelm,yelm,zelm,dershape2D_y, &
- jacobian2D_ymax,normal_ymax,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
-
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_arrays_for_cuthill (ispecb4,xstore,ystore,zstore,ibelm_ymax,normal_ymax,&
- jacobian2D_ymax,NSPEC2DMAX_YMIN_YMAX,NGLLX,NGLLZ,nspec)
- endif
- endif
-
-! on boundary: bottom
-
- if(iboun(5,ispec)) then
-
- ispecb5=ispecb5+1
- ibelm_bottom(ispecb5)=ispec
-
- xelm(1)=xstore(1,1,1,ispec)
- yelm(1)=ystore(1,1,1,ispec)
- zelm(1)=zstore(1,1,1,ispec)
- xelm(2)=xstore(NGLLX,1,1,ispec)
- yelm(2)=ystore(NGLLX,1,1,ispec)
- zelm(2)=zstore(NGLLX,1,1,ispec)
- xelm(3)=xstore(NGLLX,NGLLY,1,ispec)
- yelm(3)=ystore(NGLLX,NGLLY,1,ispec)
- zelm(3)=zstore(NGLLX,NGLLY,1,ispec)
- xelm(4)=xstore(1,NGLLY,1,ispec)
- yelm(4)=ystore(1,NGLLY,1,ispec)
- zelm(4)=zstore(1,NGLLY,1,ispec)
- xelm(5)=xstore((NGLLX+1)/2,1,1,ispec)
- yelm(5)=ystore((NGLLX+1)/2,1,1,ispec)
- zelm(5)=zstore((NGLLX+1)/2,1,1,ispec)
- xelm(6)=xstore(NGLLX,(NGLLY+1)/2,1,ispec)
- yelm(6)=ystore(NGLLX,(NGLLY+1)/2,1,ispec)
- zelm(6)=zstore(NGLLX,(NGLLY+1)/2,1,ispec)
- xelm(7)=xstore((NGLLX+1)/2,NGLLY,1,ispec)
- yelm(7)=ystore((NGLLX+1)/2,NGLLY,1,ispec)
- zelm(7)=zstore((NGLLX+1)/2,NGLLY,1,ispec)
- xelm(8)=xstore(1,(NGLLY+1)/2,1,ispec)
- yelm(8)=ystore(1,(NGLLY+1)/2,1,ispec)
- zelm(8)=zstore(1,(NGLLY+1)/2,1,ispec)
- xelm(9)=xstore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
- yelm(9)=ystore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
- zelm(9)=zstore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
-
- call compute_jacobian_2D(myrank,ispecb5,xelm,yelm,zelm,dershape2D_bottom, &
- jacobian2D_bottom,normal_bottom,NGLLX,NGLLY,NSPEC2D_BOTTOM)
-
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_arrays_for_cuthill (ispecb5,xstore,ystore,zstore,ibelm_bottom,normal_bottom,&
- jacobian2D_bottom,NSPEC2D_BOTTOM,NGLLX,NGLLY,nspec)
- endif
- endif
-
-! on boundary: top
-
- if(iboun(6,ispec)) then
-
- ispecb6=ispecb6+1
- ibelm_top(ispecb6)=ispec
-
- xelm(1)=xstore(1,1,NGLLZ,ispec)
- yelm(1)=ystore(1,1,NGLLZ,ispec)
- zelm(1)=zstore(1,1,NGLLZ,ispec)
- xelm(2)=xstore(NGLLX,1,NGLLZ,ispec)
- yelm(2)=ystore(NGLLX,1,NGLLZ,ispec)
- zelm(2)=zstore(NGLLX,1,NGLLZ,ispec)
- xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
- yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
- zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
- xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
- yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
- zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
- xelm(5)=xstore((NGLLX+1)/2,1,NGLLZ,ispec)
- yelm(5)=ystore((NGLLX+1)/2,1,NGLLZ,ispec)
- zelm(5)=zstore((NGLLX+1)/2,1,NGLLZ,ispec)
- xelm(6)=xstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
- yelm(6)=ystore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
- zelm(6)=zstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
- xelm(7)=xstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
- yelm(7)=ystore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
- zelm(7)=zstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
- xelm(8)=xstore(1,(NGLLY+1)/2,NGLLZ,ispec)
- yelm(8)=ystore(1,(NGLLY+1)/2,NGLLZ,ispec)
- zelm(8)=zstore(1,(NGLLY+1)/2,NGLLZ,ispec)
- xelm(9)=xstore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
- yelm(9)=ystore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
- zelm(9)=zstore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
-
- call compute_jacobian_2D(myrank,ispecb6,xelm,yelm,zelm,dershape2D_top, &
- jacobian2D_top,normal_top,NGLLX,NGLLY,NSPEC2D_TOP)
-
- if (PERFORM_CUTHILL_MCKEE) then
- call sort_arrays_for_cuthill (ispecb6,xstore,ystore,zstore,ibelm_top,normal_top,&
- jacobian2D_top,NSPEC2D_TOP,NGLLX,NGLLY,nspec)
- endif
- endif
-
- enddo
-
-
-! check theoretical value of elements at the bottom
- if(ispecb5 /= NSPEC2D_BOTTOM) then
- call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM')
- endif
-
-! check theoretical value of elements at the top
- if(ispecb6 /= NSPEC2D_TOP) call exit_MPI(myrank,'ispecb6 should equal NSPEC2D_TOP')
-
- nspec2D_xmin = ispecb1
- nspec2D_xmax = ispecb2
- nspec2D_ymin = ispecb3
- nspec2D_ymax = ispecb4
-
- end subroutine get_jacobian_boundaries
-
-! -------------------------------------------------------
-
- subroutine compute_jacobian_2D(myrank,ispecb,xelm,yelm,zelm,dershape2D,jacobian2D,normal,NGLLA,NGLLB,NSPEC2DMAX_AB)
-
- implicit none
-
- include "constants.h"
-
-! generic routine that accepts any polynomial degree in each direction
-
- integer ispecb,NGLLA,NGLLB,NSPEC2DMAX_AB,myrank
-
- double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
- double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
-
- real(kind=CUSTOM_REAL) jacobian2D(NGLLA,NGLLB,NSPEC2DMAX_AB)
- real(kind=CUSTOM_REAL) normal(3,NGLLA,NGLLB,NSPEC2DMAX_AB)
-
- integer i,j,ia
- double precision xxi,xeta,yxi,yeta,zxi,zeta
- double precision unx,uny,unz,jacobian
-
- do j=1,NGLLB
- do i=1,NGLLA
-
- xxi=ZERO
- xeta=ZERO
- yxi=ZERO
- yeta=ZERO
- zxi=ZERO
- zeta=ZERO
- do ia=1,NGNOD2D
- xxi=xxi+dershape2D(1,ia,i,j)*xelm(ia)
- xeta=xeta+dershape2D(2,ia,i,j)*xelm(ia)
- yxi=yxi+dershape2D(1,ia,i,j)*yelm(ia)
- yeta=yeta+dershape2D(2,ia,i,j)*yelm(ia)
- zxi=zxi+dershape2D(1,ia,i,j)*zelm(ia)
- zeta=zeta+dershape2D(2,ia,i,j)*zelm(ia)
- enddo
-
-! calculate the unnormalized normal to the boundary
- unx=yxi*zeta-yeta*zxi
- uny=zxi*xeta-zeta*xxi
- unz=xxi*yeta-xeta*yxi
- jacobian=dsqrt(unx**2+uny**2+unz**2)
- if(jacobian == ZERO) call exit_MPI(myrank,'2D Jacobian undefined')
-
-! normalize normal vector and store surface jacobian
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- jacobian2D(i,j,ispecb)=sngl(jacobian)
- normal(1,i,j,ispecb)=sngl(unx/jacobian)
- normal(2,i,j,ispecb)=sngl(uny/jacobian)
- normal(3,i,j,ispecb)=sngl(unz/jacobian)
- else
- jacobian2D(i,j,ispecb)=jacobian
- normal(1,i,j,ispecb)=unx/jacobian
- normal(2,i,j,ispecb)=uny/jacobian
- normal(3,i,j,ispecb)=unz/jacobian
- endif
-
- enddo
- enddo
-
- end subroutine compute_jacobian_2D
-
-
-
-subroutine sort_arrays_for_cuthill (ispecb,xstore,ystore,zstore,ibelm,normal,jacobian2D,nspec2D,NGLL1,NGLL2,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer :: ispecb,nspec2D,NGLL1,NGLL2,nspec,ispec_tmp,dummy_var,i
-
- integer ibelm(nspec2D)
- real(kind=CUSTOM_REAL) jacobian2D(NGLL1,NGLL2,NSPEC2D)
- real(kind=CUSTOM_REAL) normal(NDIM,NGLL1,NGLL2,NSPEC2D)
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! arrays for sorting routine
- integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
- logical, dimension(:), allocatable :: ifseg
- double precision, dimension(:), allocatable :: work
- double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
- integer, dimension(:), allocatable :: perm
- integer, dimension(:), allocatable :: ibelm_tmp
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_tmp
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_tmp
-
-! get permutation
- allocate (xstore_selected(ispecb))
- allocate (ystore_selected(ispecb))
- allocate (zstore_selected(ispecb))
- allocate(ind(ispecb))
- allocate(ninseg(ispecb))
- allocate(iglob(ispecb))
- allocate(locval(ispecb))
- allocate(ifseg(ispecb))
- allocate(iwork(ispecb))
- allocate(work(ispecb))
- allocate(perm(ispecb))
-
- do ispec_tmp=1,ispecb
- xstore_selected(ispec_tmp) = xstore(1,1,1,ibelm(ispec_tmp))
- ystore_selected(ispec_tmp) = ystore(1,1,1,ibelm(ispec_tmp))
- zstore_selected(ispec_tmp) = zstore(1,1,1,ibelm(ispec_tmp))
- perm(ispec_tmp) = ispec_tmp
- enddo
-
- call sort_array_coordinates(ispecb,xstore_selected,ystore_selected,zstore_selected, &
- perm,iglob,locval,ifseg,dummy_var,ind,ninseg,iwork,work)
-
- deallocate (xstore_selected)
- deallocate (ystore_selected)
- deallocate (zstore_selected)
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iglob)
- deallocate(locval)
- deallocate(ifseg)
- deallocate(iwork)
- deallocate(work)
-
-! permutation of ibelm
- allocate(ibelm_tmp(ispecb))
- ibelm_tmp(1:ispecb) = ibelm(1:ispecb)
- do i = 1,ispecb
- ibelm(perm(i)) = ibelm_tmp(i)
- enddo
- deallocate(ibelm_tmp)
-
-! permutation of normal
- allocate(normal_tmp(NDIM,NGLL1,NGLL2,ispecb))
- normal_tmp(:,:,:,1:ispecb) = normal(:,:,:,1:ispecb)
- do i = 1,ispecb
- normal(:,:,:,perm(i)) = normal_tmp(:,:,:,i)
- enddo
- deallocate(normal_tmp)
-
-! permutation of jacobian2D
- allocate(jacobian2D_tmp(NGLL1,NGLL2,ispecb))
- jacobian2D_tmp(:,:,1:ispecb) = jacobian2D(:,:,1:ispecb)
- do i = 1,ispecb
- jacobian2D(:,:,perm(i)) = jacobian2D_tmp(:,:,i)
- enddo
- deallocate(jacobian2D_tmp)
- deallocate(perm)
-
-end subroutine sort_arrays_for_cuthill
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_model.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,997 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_model(myrank,iregion_code,nspec, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,rhostore_local, &
-!! DK DK added this for the merged version
- kappavstore_local, &
- nspec_ani, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- xelm,yelm,zelm,shape3D,ispec, &
- rmin,rmax,idoubling, &
- rho_vp,rho_vs,nspec_stacey, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE, &
- CRUSTAL,ONE_CRUST,ATTENUATION,ATTENUATION_3D,tau_s,tau_e_store,Qmu_store,T_c_source,vx,vy,vz,vnspec, &
- ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,&
- 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)
-
- implicit none
-
- include "constants.h"
-
-!! DK DK for the merged version
-! include values created by the mesher
- include "OUTPUT_FILES/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(:), pointer :: 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
-
-! 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
-
- integer ispec,nspec,idoubling,iregion_code,myrank,nspec_stacey
- integer REFERENCE_1D_MODEL,THREE_D_MODEL
-
- logical ATTENUATION,ATTENUATION_3D,ABSORBING_CONDITIONS
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST
-
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
- double precision rmin,rmax,RCMB,RICB,R670,RMOHO, &
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) kappahstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muhstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec)
-
-!! DK DK added this for the merged version
- real(kind=CUSTOM_REAL) kappavstore_local(NGLLX,NGLLY,NGLLZ)
-
-!! DK DK changed this for merged version
- real(kind=CUSTOM_REAL) rhostore_local(NGLLX,NGLLY,NGLLZ)
-
- real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey),rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
-
- integer nspec_ani
-
-! the 21 coefficients for an anisotropic medium in reduced notation
- double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33, &
- c34,c35,c36,c44,c45,c46,c55,c56,c66
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store, &
- c33store,c34store,c35store,c36store, &
- c44store,c45store,c46store,c55store,c56store,c66store
-
- double precision xmesh,ymesh,zmesh
-
- integer i,j,k,ia
- double precision rho,drhodr,vp,vs,Qkappa,Qmu
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision dvp,dvs,drho
- real(kind=4) xcolat,xlon,xrad,dvpv,dvph,dvsv,dvsh
- double precision xstore(NGLLX,NGLLY,NGLLZ)
- double precision ystore(NGLLX,NGLLY,NGLLZ)
- double precision zstore(NGLLX,NGLLY,NGLLZ)
- double precision r,r_prem,r_moho,r_dummy,theta,phi
- double precision lat,lon
- double precision vpc,vsc,rhoc,moho
-
-! attenuation values
- integer vx, vy, vz, vnspec
- double precision, dimension(N_SLS) :: tau_s, tau_e
- double precision, dimension(vx, vy, vz, vnspec) :: Qmu_store
- double precision, dimension(N_SLS, vx, vy, vz, vnspec) :: tau_e_store
- double precision T_c_source
-
- logical found_crust
-
- 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)
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- xmesh = ZERO
- ymesh = ZERO
- zmesh = ZERO
- do ia=1,NGNOD
- xmesh = xmesh + shape3D(ia,i,j,k)*xelm(ia)
- ymesh = ymesh + shape3D(ia,i,j,k)*yelm(ia)
- zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
- enddo
- r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
-
- xstore(i,j,k) = xmesh
- ystore(i,j,k) = ymesh
- zstore(i,j,k) = zmesh
-
-! make sure we are within the right shell in PREM to honor discontinuities
-! use small geometrical tolerance
- r_prem = r
- if(r <= rmin*1.000001d0) r_prem = rmin*1.000001d0
- if(r >= rmax*0.999999d0) r_prem = rmax*0.999999d0
-
-! get the anisotropic PREM parameters
- if(TRANSVERSE_ISOTROPY) then
- if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
- call prem_aniso(myrank,r_prem,rho,vpv,vph,vsv,vsh,eta_aniso, &
- Qkappa,Qmu,idoubling,CRUSTAL,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
- call model_ref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
-
- else
- stop 'unknown 1D transversely isotropic reference Earth model in get_model'
- endif
-
- else
-
- if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
- call model_iasp91(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
- ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST)
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
- call prem_iso(myrank,r_prem,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, &
- ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
- call model_1066a(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V)
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
- call model_ak135(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V)
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
- call model_ref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
- if(.not. ISOTROPIC_3D_MANTLE) then
- vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
- vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
- endif
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
- call model_jp1d(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
- .true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
- vpv = vp
- vph = vp
- vsv = vs
- vsh = vs
- eta_aniso = 1.d0
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
- call model_sea1d(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
- vpv = vp
- vph = vp
- vsv = vs
- vsh = vs
- eta_aniso = 1.d0
- else
- stop 'unknown 1D reference Earth model in get_model'
- endif
-
- ! in the case of s362iso we want to save the anisotropic constants for the Voight average
- if(.not. (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF .and. ISOTROPIC_3D_MANTLE)) then
- vpv = vp
- vph = vp
- vsv = vs
- vsh = vs
- eta_aniso = 1.d0
- endif
- endif
-
-! get the 3-D model parameters
- if(ISOTROPIC_3D_MANTLE) then
- if(r_prem > RCMB/R_EARTH .and. r_prem < RMOHO/R_EARTH) then
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
- call reduce(theta,phi)
- if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
-! s20rts
- dvs = ZERO
- dvp = ZERO
- drho = ZERO
- call mantle_model(r,theta,phi,dvs,dvp,drho,D3MM_V)
- vpv=vpv*(1.0d0+dvp)
- vph=vph*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- rho=rho*(1.0d0+drho)
- elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
-! sea99 + jp3d1994
- dvs = ZERO
- dvp = ZERO
- drho = ZERO
- call sea99_s_model(r,theta,phi,dvs,SEA99M_V)
- vpv=vpv*(1.0d0+dvp)
- vph=vph*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- rho=rho*(1.0d0+drho)
-! use Lebedev model as background and add vp & vs perturbation from Zhao 1994 model
- if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
- .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
- if(r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
- call iso3d_dpzhao_model(r,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
- vpv=vpv*(1.0d0+dvp)
- vph=vph*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- endif
- endif
- elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
-! sea99
- dvs = ZERO
- dvp = ZERO
- drho = ZERO
- call sea99_s_model(r,theta,phi,dvs,SEA99M_V)
- vpv=vpv*(1.0d0+dvp)
- vph=vph*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- rho=rho*(1.0d0+drho)
- elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
-! jp3d1994
- dvs = ZERO
- dvp = ZERO
- drho = ZERO
- if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
- .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
- if(r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
- call iso3d_dpzhao_model(r,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
- vpv=vpv*(1.0d0+dvp)
- vph=vph*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- endif
- 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
-! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
- dvpv = 0.
- dvph = 0.
- dvsv = 0.
- dvsh = 0.
- xcolat = sngl(theta*180.0d0/PI)
- xlon = sngl(phi*180.0d0/PI)
- xrad = sngl(r*R_EARTH_KM)
- call subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
- 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)
- if(TRANSVERSE_ISOTROPY) then
- vpv=vpv*(1.0d0+dble(dvpv))
- vph=vph*(1.0d0+dble(dvph))
- vsv=vsv*(1.0d0+dble(dvsv))
- vsh=vsh*(1.0d0+dble(dvsh))
- else
- vpv=vpv+dvpv
- vph=vph+dvph
- vsv=vsv+dvsv
- vsh=vsh+dvsh
- vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
- vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
- vpv=vp
- vph=vp
- vsv=vs
- vsh=vs
- eta_aniso=1.0d0
- endif
- else
- stop 'unknown 3D Earth model in get_model'
- endif
-
-! extend 3-D mantle model above the Moho to the surface before adding the crust
- else if(r_prem >= RMOHO/R_EARTH) then
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
- call reduce(theta,phi)
- r_moho = 0.999999d0*RMOHO/R_EARTH
- if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
-! s20rts
- dvs = ZERO
- dvp = ZERO
- drho = ZERO
- call mantle_model(r_moho,theta,phi,dvs,dvp,drho,D3MM_V)
- vpv=vpv*(1.0d0+dvp)
- vph=vph*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- rho=rho*(1.0d0+drho)
- elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
-! sea99 + jp3d1994
- dvs = ZERO
- dvp = ZERO
- drho = ZERO
- call sea99_s_model(r_moho,theta,phi,dvs,SEA99M_V)
- vpv=vpv*(1.0d0+dvp)
- vph=vph*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- rho=rho*(1.0d0+drho)
-! use Lebedev's model as background and add vp & vs perturbation from Zhao's 1994 model
- if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
- .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
- call iso3d_dpzhao_model(r_moho,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
- vpv=vpv*(1.0d0+dvp)
- vph=vph*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- endif
- elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
-! sea99
- dvs = ZERO
- dvp = ZERO
- drho = ZERO
- call sea99_s_model(r_moho,theta,phi,dvs,SEA99M_V)
- vpv=vpv*(1.0d0+dvp)
- vph=vph*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- rho=rho*(1.0d0+drho)
- elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
-! jp3d1994
- dvs = ZERO
- dvp = ZERO
- drho = ZERO
- if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
- .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
- call iso3d_dpzhao_model(r_moho,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
- vpv=vpv*(1.0d0+dvp)
- vph=vph*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- 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
-! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
- dvpv = 0.
- dvph = 0.
- dvsv = 0.
- dvsh = 0.
- xcolat = sngl(theta*180.0d0/PI)
- xlon = sngl(phi*180.0d0/PI)
- xrad = sngl(r_moho*R_EARTH_KM)
- call subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
- 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)
- if(TRANSVERSE_ISOTROPY) then
- vpv=vpv*(1.0d0+dble(dvpv))
- vph=vph*(1.0d0+dble(dvph))
- vsv=vsv*(1.0d0+dble(dvsv))
- vsh=vsh*(1.0d0+dble(dvsh))
- else
- vpv=vpv+dvpv
- vph=vph+dvph
- vsv=vsv+dvsv
- vsh=vsh+dvsh
- vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
- vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
- vpv=vp
- vph=vp
- vsv=vs
- vsh=vs
- eta_aniso=1.0d0
- endif
- else
- stop 'unknown 3D Earth model in get_model'
- endif
-
- endif
- endif
-
- if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) &
- call aniso_inner_core_model(r_prem,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL)
-
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
-
-! anisotropic model between the Moho and 670 km (change to CMB if desired)
- if(r_prem < RMOHO/R_EARTH .and. r_prem > R670/R_EARTH) then
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
- call reduce(theta,phi)
- call aniso_mantle_model(r_prem,theta,phi,rho,c11,c12,c13,c14,c15,c16, &
- c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,AMM_V)
-! extend 3-D mantle model above the Moho to the surface before adding the crust
- elseif(r_prem >= RMOHO/R_EARTH) then
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
- call reduce(theta,phi)
- r_moho = RMOHO/R_EARTH
- call aniso_mantle_model(r_moho,theta,phi,rho,c11,c12,c13,c14,c15,c16, &
- c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,AMM_V)
-! fill the rest of the mantle with the isotropic model
- else
- c11 = rho*vpv*vpv
- c12 = rho*(vpv*vpv-2.*vsv*vsv)
- c13 = c12
- c14 = 0.
- c15 = 0.
- c16 = 0.
- c22 = c11
- c23 = c12
- c24 = 0.
- c25 = 0.
- c26 = 0.
- c33 = c11
- c34 = 0.
- c35 = 0.
- c36 = 0.
- c44 = rho*vsv*vsv
- c45 = 0.
- c46 = 0.
- c55 = c44
- c56 = 0.
- c66 = c44
- endif
- endif
-
-! This is here to identify how and where to include 3D attenuation
- if(ATTENUATION .and. ATTENUATION_3D) then
- tau_e(:) = 0.0d0
- ! Get the value of Qmu (Attenuation) dependedent on
- ! the radius (r_prem) and idoubling flag
- call attenuation_model_1D_PREM(r_prem, Qmu, idoubling)
- ! Get tau_e from tau_s and Qmu
- call attenuation_conversion(Qmu, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
- endif
-
-! get the 3-D crustal model
- if(CRUSTAL) then
- if(r > R_DEEPEST_CRUST) then
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
- call reduce(theta,phi)
-
- if(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D .or. THREE_D_MODEL == THREE_D_MODEL_JP3D) then
- if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
- .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
- if(r > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
- call iso3d_dpzhao_model(r,theta,phi,vpc,vsc,dvp,dvs,rhoc,found_crust,JP3DM_V)
- if(found_crust) then
- vpv=vpc
- vph=vpc
- vsv=vsc
- vsh=vsc
-! rho=rhoc
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
- c11 = rho*vpv*vpv
- c12 = rho*(vpv*vpv-2.*vsv*vsv)
- c13 = c12
- c14 = 0.
- c15 = 0.
- c16 = 0.
- c22 = c11
- c23 = c12
- c24 = 0.
- c25 = 0.
- c26 = 0.
- c33 = c11
- c34 = 0.
- c35 = 0.
- c36 = 0.
- c44 = rho*vsv*vsv
- c45 = 0.
- c46 = 0.
- c55 = c44
- c56 = 0.
- c66 = c44
- endif
- endif
- endif
- else
- lat=(PI/2.0d0-theta)*180.0d0/PI
- lon=phi*180.0d0/PI
- if(lon>180.0d0) lon=lon-360.0d0
- call crustal_model(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V)
- if (found_crust) then
- vpv=vpc
- vph=vpc
- vsv=vsc
- vsh=vsc
- rho=rhoc
- eta_aniso=1.0d0
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
- c11 = rho*vpv*vpv
- c12 = rho*(vpv*vpv-2.*vsv*vsv)
- c13 = c12
- c14 = 0.
- c15 = 0.
- c16 = 0.
- c22 = c11
- c23 = c12
- c24 = 0.
- c25 = 0.
- c26 = 0.
- c33 = c11
- c34 = 0.
- c35 = 0.
- c36 = 0.
- c44 = rho*vsv*vsv
- c45 = 0.
- c46 = 0.
- c55 = c44
- c56 = 0.
- c66 = c44
- endif
- endif
- endif
- else
- lat=(PI/2.0d0-theta)*180.0d0/PI
- lon=phi*180.0d0/PI
- if(lon>180.0d0) lon=lon-360.0d0
- call crustal_model(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V)
- if (found_crust) then
- vpv=vpc
- vph=vpc
- vsv=vsc
- vsh=vsc
- rho=rhoc
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
- c11 = rho*vpv*vpv
- c12 = rho*(vpv*vpv-2.*vsv*vsv)
- c13 = c12
- c14 = 0.
- c15 = 0.
- c16 = 0.
- c22 = c11
- c23 = c12
- c24 = 0.
- c25 = 0.
- c26 = 0.
- c33 = c11
- c34 = 0.
- c35 = 0.
- c36 = 0.
- c44 = rho*vsv*vsv
- c45 = 0.
- c46 = 0.
- c55 = c44
- c56 = 0.
- c66 = c44
- endif
- endif
- endif
- endif
- endif
-
-! define elastic parameters in the model
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
-
-!! DK DK changed this for merged version
- rhostore_local(i,j,k) = sngl(rho)
-
-!! DK DK added this for merged version
- if(iregion_code /= IREGION_OUTER_CORE) then
- kappavstore(i,j,k,ispec) = sngl(rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0))
- if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) &
- kappahstore(i,j,k,ispec) = sngl(rho*(vph*vph - 4.d0*vsh*vsh/3.d0))
- muvstore(i,j,k,ispec) = sngl(rho*vsv*vsv)
- if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) muhstore(i,j,k,ispec) = sngl(rho*vsh*vsh)
- if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) eta_anisostore(i,j,k,ispec) = sngl(eta_aniso)
- else
-!! DK DK added this for merged version
- kappavstore_local(i,j,k) = sngl(rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0))
- endif
-
- if(ABSORBING_CONDITIONS) then
-
- if(iregion_code == IREGION_OUTER_CORE) then
-
-! we need just vp in the outer core for Stacey conditions
- rho_vp(i,j,k,ispec) = sngl(vph)
- rho_vs(i,j,k,ispec) = sngl(0.d0)
- else
-
- rho_vp(i,j,k,ispec) = sngl(rho*vph)
- rho_vs(i,j,k,ispec) = sngl(rho*vsh)
- endif
- endif
-
- if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
-
- c11store(i,j,k,ispec) = sngl(c11)
- c33store(i,j,k,ispec) = sngl(c33)
- c12store(i,j,k,ispec) = sngl(c12)
- c13store(i,j,k,ispec) = sngl(c13)
- c44store(i,j,k,ispec) = sngl(c44)
- endif
-
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
-
- c11store(i,j,k,ispec) = sngl(c11)
- c12store(i,j,k,ispec) = sngl(c12)
- c13store(i,j,k,ispec) = sngl(c13)
- c14store(i,j,k,ispec) = sngl(c14)
- c15store(i,j,k,ispec) = sngl(c15)
- c16store(i,j,k,ispec) = sngl(c16)
- c22store(i,j,k,ispec) = sngl(c22)
- c23store(i,j,k,ispec) = sngl(c23)
- c24store(i,j,k,ispec) = sngl(c24)
- c25store(i,j,k,ispec) = sngl(c25)
- c26store(i,j,k,ispec) = sngl(c26)
- c33store(i,j,k,ispec) = sngl(c33)
- c34store(i,j,k,ispec) = sngl(c34)
- c35store(i,j,k,ispec) = sngl(c35)
- c36store(i,j,k,ispec) = sngl(c36)
- c44store(i,j,k,ispec) = sngl(c44)
- c45store(i,j,k,ispec) = sngl(c45)
- c46store(i,j,k,ispec) = sngl(c46)
- c55store(i,j,k,ispec) = sngl(c55)
- c56store(i,j,k,ispec) = sngl(c56)
- c66store(i,j,k,ispec) = sngl(c66)
- endif
-
- else
-
-!! DK DK changed this for merged version
- rhostore_local(i,j,k) = rho
-
-!! DK DK added this for merged version
- if(iregion_code /= IREGION_OUTER_CORE) then
- kappavstore(i,j,k,ispec) = rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0)
- if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) &
- kappahstore(i,j,k,ispec) = rho*(vph*vph - 4.d0*vsh*vsh/3.d0)
- muvstore(i,j,k,ispec) = rho*vsv*vsv
- if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) muhstore(i,j,k,ispec) = rho*vsh*vsh
- if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) eta_anisostore(i,j,k,ispec) = eta_aniso
- else
-!! DK DK added this for merged version
- kappavstore_local(i,j,k) = rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0)
- endif
-
- if(ABSORBING_CONDITIONS) then
- if(iregion_code == IREGION_OUTER_CORE) then
-! we need just vp in the outer core for Stacey conditions
- rho_vp(i,j,k,ispec) = vph
- rho_vs(i,j,k,ispec) = 0.d0
- else
- rho_vp(i,j,k,ispec) = rho*vph
- rho_vs(i,j,k,ispec) = rho*vsh
- endif
- endif
-
- if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
- c11store(i,j,k,ispec) = c11
- c33store(i,j,k,ispec) = c33
- c12store(i,j,k,ispec) = c12
- c13store(i,j,k,ispec) = c13
- c44store(i,j,k,ispec) = c44
- endif
-
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
- c11store(i,j,k,ispec) = c11
- c12store(i,j,k,ispec) = c12
- c13store(i,j,k,ispec) = c13
- c14store(i,j,k,ispec) = c14
- c15store(i,j,k,ispec) = c15
- c16store(i,j,k,ispec) = c16
- c22store(i,j,k,ispec) = c22
- c23store(i,j,k,ispec) = c23
- c24store(i,j,k,ispec) = c24
- c25store(i,j,k,ispec) = c25
- c26store(i,j,k,ispec) = c26
- c33store(i,j,k,ispec) = c33
- c34store(i,j,k,ispec) = c34
- c35store(i,j,k,ispec) = c35
- c36store(i,j,k,ispec) = c36
- c44store(i,j,k,ispec) = c44
- c45store(i,j,k,ispec) = c45
- c46store(i,j,k,ispec) = c46
- c55store(i,j,k,ispec) = c55
- c56store(i,j,k,ispec) = c56
- c66store(i,j,k,ispec) = c66
- endif
-
- endif
-
- if(ATTENUATION .and. ATTENUATION_3D) then
- tau_e_store(:,i,j,k,ispec) = tau_e(:)
- Qmu_store(i,j,k,ispec) = Qmu
- endif
-
- enddo
- enddo
- enddo
-
- end subroutine get_model
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_perm_cuthill_mckee.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_perm_cuthill_mckee.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_perm_cuthill_mckee.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,804 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! implement reverse Cuthill-McKee (1969) ordering, introduced in
-! E. Cuthill and J. McKee. Reducing the bandwidth of sparse symmetric matrices.
-! In Proceedings of the 1969 24th national conference, pages 157-172,
-! New-York, New-York, USA, 1969. ACM Press.
-! see for instance http://en.wikipedia.org/wiki/Cuthill%E2%80%93McKee_algorithm
-
- subroutine get_perm(ibool,perm,limit,nspec,nglob,INVERSE,FACE)
-
- implicit none
-
- include "constants.h"
-
- logical :: INVERSE,FACE
-
-! input
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
-! output
- integer, dimension(nspec) :: perm
-
-! local variables
- integer nspec,nglob_GLL_full
-
-! a neighbor of a hexahedral node is a hexahedra which share a face whith it -> max degre of a node = 6
- integer, parameter :: MAX_NUMBER_OF_NEIGHBORS = 100
-
-! global corner numbers that need to be created
- integer, dimension(nglob) :: global_corner_number
-
- integer mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
- integer, dimension(:), allocatable :: ne,np,adj
- integer xadj(nspec+1)
-
-! arrays to store the permutation and inverse permutation of the Cuthill-McKee algorithm
- integer, dimension(nspec) :: invperm
-
- logical maskel(nspec)
-
- integer i,istart,istop,number_of_neighbors
-
- integer nglob_eight_corners_only,nglob
-
-! only count the total size of the array that will be created, or actually create it
- logical count_only
- integer total_size_ne,total_size_adj,limit
-
-!
-!-----------------------------------------------------------------------
-!
- if(PERFORM_CUTHILL_MCKEE) then
-
- ! total number of points in the mesh
- nglob_GLL_full = nglob
-
- !---- call Charbel Farhat's routines
- call form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,nglob_GLL_full,ibool,nglob_eight_corners_only)
- do i=1,nspec
- istart = mp(i)
- istop = mp(i+1) - 1
- enddo
-
- allocate(np(nglob_eight_corners_only+1))
- count_only = .true.
- total_size_ne = 1
- allocate(ne(total_size_ne))
- call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,nspec,count_only,total_size_ne)
- deallocate(ne)
- allocate(ne(total_size_ne))
- count_only = .false.
- call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,nspec,count_only,total_size_ne)
- do i=1,nglob_eight_corners_only
- istart = np(i)
- istop = np(i+1) - 1
- enddo
-
- count_only = .true.
- total_size_adj = 1
- allocate(adj(total_size_adj))
- call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,&
- count_only,total_size_ne,total_size_adj,FACE)
- deallocate(adj)
- allocate(adj(total_size_adj))
- count_only = .false.
- call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,&
- count_only,total_size_ne,total_size_adj,FACE)
- do i=1,nspec
- istart = xadj(i)
- istop = xadj(i+1) - 1
- number_of_neighbors = istop-istart+1
- if(number_of_neighbors < 1 .or. number_of_neighbors > MAX_NUMBER_OF_NEIGHBORS) stop 'incorrect number of neighbors'
- enddo
- deallocate(ne,np)
-
-! call the Cuthill-McKee sorting algorithm
- call cuthill_mckee(adj,xadj,perm,invperm,nspec,total_size_adj,limit,INVERSE)
- deallocate(adj)
- else
-! create identity permutation in order to do nothing
- do i=1,nspec
- perm(i) = i
- enddo
- endif
-
- end subroutine get_perm
-
-!=======================================================================
-!
-! Charbel Farhat's FEM topology routines
-!
-! Dimitri Komatitsch, February 1996 - Code based on Farhat's original version
-! described in his technical report from 1987
-!
-! modified and adapted by Dimitri Komatitsch, May 2006
-!
-!=======================================================================
-
- subroutine form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number, &
- nglob_GLL_full,ibool,nglob_eight_corners_only)
-
-!-----------------------------------------------------------------------
-!
-! Forms the MN and MP arrays
-!
-! Input :
-! -------
-! ibool Array needed to build the element connectivity table
-! nspec Number of elements in the domain
-! NGNOD_HEXAHEDRA number of nodes per hexahedron (brick with 8 corners)
-!
-! Output :
-! --------
-! MN, MP This is the element connectivity array pair.
-! Array MN contains the list of the element
-! connectivity, that is, the nodes contained in each
-! element. They are stored in a stacked fashion.
-!
-! Pointer array MP stores the location of each
-! element list. Its length is equal to the number
-! of elements plus one.
-!
-!-----------------------------------------------------------------------
-
- implicit none
-
- include "constants.h"
-
- integer nspec,nglob_GLL_full
-
-! arrays with mesh parameters per slice
- integer, intent(in), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
-! global corner numbers that need to be created
- integer, intent(out), dimension(nglob_GLL_full) :: global_corner_number
- integer, intent(out) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
- integer, intent(out) :: nglob_eight_corners_only
-
- integer ninter,nsum,ispec,node,k,inumcorner,ix,iy,iz
-
- ninter = 1
- nsum = 1
- mp(1) = 1
-
-!---- define topology of the elements in the mesh
-!---- we need to define adjacent numbers from the sub-mesh consisting of the corners only
- nglob_eight_corners_only = 0
- global_corner_number(:) = -1
-
- do ispec=1,nspec
-
- inumcorner = 0
- do iz = 1,NGLLZ,NGLLZ-1
- do iy = 1,NGLLY,NGLLY-1
- do ix = 1,NGLLX,NGLLX-1
-
- inumcorner = inumcorner + 1
- if(inumcorner > NGNOD_HEXAHEDRA) stop 'corner number too large'
-
-! check if this point was already assigned a number previously, otherwise create one and store it
- if(global_corner_number(ibool(ix,iy,iz,ispec)) == -1) then
- nglob_eight_corners_only = nglob_eight_corners_only + 1
- global_corner_number(ibool(ix,iy,iz,ispec)) = nglob_eight_corners_only
- endif
-
- node = global_corner_number(ibool(ix,iy,iz,ispec))
- do k=nsum,ninter-1
- if(node == mn(k)) goto 200
- enddo
-
- mn(ninter) = node
- ninter = ninter + 1
- 200 continue
-
- enddo
- enddo
- enddo
-
- nsum = ninter
- mp(ispec + 1) = nsum
-
- enddo
-
- end subroutine form_elt_connectivity_foelco
-
-!
-!----------------------------------------------------
-!
-
- subroutine form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only, &
- nspec,count_only,total_size_ne)
-
-!-----------------------------------------------------------------------
-!
-! Forms the NE and NP arrays
-!
-! Input :
-! -------
-! MN, MP, nspec
-! nglob_eight_corners_only Number of nodes in the domain
-!
-! Output :
-! --------
-! NE, NP This is the node-connected element array pair.
-! Integer array NE contains a list of the
-! elements connected to each node, stored in stacked fashion.
-!
-! Array NP is the pointer array for the
-! location of a node's element list in the NE array.
-! Its length is equal to the number of points plus one.
-!
-!-----------------------------------------------------------------------
-
- implicit none
-
- include "constants.h"
-
-! only count the total size of the array that will be created, or actually create it
- logical count_only
- integer total_size_ne
-
- integer nglob_eight_corners_only,nspec
-
- integer, intent(in) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
-
- integer, intent(out) :: ne(total_size_ne),np(nglob_eight_corners_only+1)
-
- integer nsum,inode,ispec,j
-
- nsum = 1
- np(1) = 1
-
- do inode=1,nglob_eight_corners_only
- do 200 ispec=1,nspec
-
- do j=mp(ispec),mp(ispec + 1) - 1
- if (mn(j) == inode) then
- if(count_only) then
- total_size_ne = nsum
- else
- ne(nsum) = ispec
- endif
- nsum = nsum + 1
- goto 200
- endif
- enddo
- 200 continue
-
- np(inode + 1) = nsum
-
- enddo
-
- end subroutine form_node_connectivity_fonoco
-
-!
-!----------------------------------------------------
-!
-
- subroutine create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec, &
- nglob_eight_corners_only,count_only,total_size_ne,total_size_adj,face)
-
-!-----------------------------------------------------------------------
-!
-! Establishes the element adjacency information of the mesh
-! Two elements are considered adjacent if they share a face.
-!
-! Input :
-! -------
-! MN, MP, NE, NP, nspec
-! MASKEL logical mask (length = nspec)
-!
-! Output :
-! --------
-! ADJ, XADJ This is the element adjacency array pair. Array
-! ADJ contains the list of the elements adjacent to
-! element i. They are stored in a stacked fashion.
-! Pointer array XADJ stores the location of each element list.
-!
-!-----------------------------------------------------------------------
-
- implicit none
-
- include "constants.h"
-
-! only count the total size of the array that will be created, or actually create it
- logical count_only,face
- integer total_size_ne,total_size_adj
-
- integer nglob_eight_corners_only
-
- integer, intent(in) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1),ne(total_size_ne),np(nglob_eight_corners_only+1)
-
- integer, intent(out) :: adj(total_size_adj),xadj(nspec+1)
-
- logical maskel(nspec)
- integer countel(nspec)
-
- integer nspec,iad,ispec,istart,istop,ino,node,jstart,jstop,nelem,jel
-
- xadj(1) = 1
- iad = 1
-
- do ispec=1,nspec
-
-! reset mask
- maskel(:) = .false.
-
-! mask current element
- maskel(ispec) = .true.
- if (face) countel(:) = 0
-
- istart = mp(ispec)
- istop = mp(ispec+1) - 1
- do ino=istart,istop
- node = mn(ino)
- jstart = np(node)
- jstop = np(node + 1) - 1
- do 120 jel=jstart,jstop
- nelem = ne(jel)
- if(maskel(nelem)) goto 120
- if (face) then
- ! if 2 elements share at least 3 corners, therefore they share a face
- countel(nelem) = countel(nelem) + 1
- if (countel(nelem)>=3) then
- if(count_only) then
- total_size_adj = iad
- else
- adj(iad) = nelem
- endif
- maskel(nelem) = .true.
- iad = iad + 1
- endif
- else
- if(count_only) then
- total_size_adj = iad
- else
- adj(iad) = nelem
- endif
- maskel(nelem) = .true.
- iad = iad + 1
- endif
- 120 continue
- enddo
-
- xadj(ispec+1) = iad
-
- enddo
-
- end subroutine create_adjacency_table_adjncy
-
-!
-!----------------------------------------------------
-!
-
- subroutine cuthill_mckee(adj,xadj,mask,invperm_all,nspec,total_size_adj,limit,INVERSE)
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: nspec,total_size_adj, limit
- integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
-
- integer, intent(out), dimension(nspec) :: mask,invperm_all
- integer, dimension(nspec) :: invperm_sub
- logical :: INVERSE
- integer ispec,gsize,counter,nspec_sub,root,total_ordered_elts, next_root
-
-! fill the mask with ones
- mask(:) = 1
- invperm_all(:) = 0
- counter = 0
- nspec_sub = limit
- root = 1
- total_ordered_elts = 0
-
- do while(total_ordered_elts < nspec)
- ! creation of a sublist of sorted elements which fit in the cache (the criterion of size is limit)
- ! limit = nb of element that can fit in the L2 cache
- call Cut_McK( root, nspec, total_size_adj, xadj, adj, mask, gsize, invperm_sub, limit, nspec_sub, next_root)
- ! add the sublist in the main permutation list
- invperm_all(total_ordered_elts+1:total_ordered_elts+nspec_sub) = invperm_sub(1:nspec_sub)
- total_ordered_elts = total_ordered_elts + nspec_sub
- ! seek for a new root to build the new sublist
- if (next_root > 0) then
- root = next_root
- else
- if (total_ordered_elts /= nspec) &
- call find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
- root = next_root
- endif
- enddo
-
- if (INVERSE) then
- do ispec=1,nspec
- mask(invperm_all(ispec)) = ispec
- enddo
- else
- mask(:) = invperm_all(:)
- endif
-
- end subroutine cuthill_mckee
-
-
-!*******************************************************************************
-! Objective: Cuthill-McKee ordering
-! The algorithm is:
-!
-! X(1) = ROOT.
-! for ( I = 1 to N-1)
-! Find all unlabeled neighbors of X(I),
-! assign them the next available labels, in order of increasing degree.
-!
-! Parameters:
-! root the starting point for the cm ordering.
-! nbnodes the number of nodes.
-! nnz the number of adjacency entries.
-!
-! xadj/adj the graph
-! mask only those nodes with nonzero mask are considered
-!
-! gsize the number of the connected component
-! invp Inverse invputation (from new order to old order)
-!*******************************************************************************
-
-subroutine find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
-
- implicit none
-
- include "constants.h"
-
-! input
- integer, intent(in) :: total_size_adj,total_ordered_elts,nspec
- integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
- integer, intent(in), dimension(nspec) :: mask,invperm_all
-! output
- integer, intent(out) :: next_root
-! variables
- integer :: cur_node,neighbor_node,i,j
-
- do i=total_ordered_elts, 1, -1
- cur_node = invperm_all(i)
- do j= xadj(cur_node), xadj(cur_node+1)-1
- neighbor_node = adj(j)
- if (mask(neighbor_node)/=0) then
- next_root=neighbor_node
- return
- endif
- enddo
- enddo
-
-end subroutine find_next_root
-
-!*******************************************************************************
-! Objective: Cuthill-McKee ordering
-! The algorithm is:
-!
-! X(1) = ROOT.
-! for ( I = 1 to N-1)
-! Find all unlabeled neighbors of X(I),
-! assign them the next available labels, in order of increasing degree.
-!
-! Parameters:
-! root the starting point for the cm ordering.
-! nbnodes the number of nodes.
-! nnz the number of adjacency entries.
-!
-! xadj/adj the graph
-! mask only those nodes with nonzero mask are considered
-!
-! gsize the number of the connected component
-! invp Inverse invputation (from new order to old order)
-!*******************************************************************************
-
-subroutine Cut_McK( root, nbnodes, nnz, xadj, adj, mask, gsize, invp, limit, nspec_sub, next_root)
-
- implicit none
-
- include "constants.h"
-
-!--------------------------------------------------------------- Input Variables
- integer root, nnz, nbnodes, limit, nspec_sub, next_root
-
- integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
-
-!-------------------------------------------------------------- Output Variables
- integer gsize
- integer invp(nbnodes)
-
-!--------------------------------------------------------------- Local Variables
- integer i, j, k, l, lbegin, lnbr, linvp, lvlend, nbr, node, fnbr
- integer deg(nbnodes)
-
-! Find the degrees of the nodes in the subgraph specified by mask and root
-! Here invp is used to store a levelization of the subgraph
- invp(:)=0
- deg(:)=0
- call degree ( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, invp)
-
- mask(root) = 0
-
- IF (gsize > 1) THEN
- !If there is at least 2 nodes in the subgraph
- lvlend = 0
- lnbr = 1
-
- DO while (lvlend < lnbr)
- !lbegin/lvlend point to the begin/end of the present level
- lbegin = lvlend + 1
- lvlend = lnbr
-
- do i= lbegin, lvlend
- node = invp(i)
-
- !Find the unnumbered neighbours of node.
- !fnbr/lnbr point to the first/last neighbors of node
- fnbr = lnbr + 1
- do j= xadj(node), xadj(node+1)-1
- nbr = adj(j)
-
- if (mask(nbr) /= 0) then
- lnbr = lnbr + 1
- mask(nbr) = 0
- invp(lnbr) = nbr
- endif
- enddo
-
- !If no neighbors, go to next node in this level.
- IF (lnbr > fnbr) THEN
- !Sort the neighbors of NODE in increasing order by degree.
- !Linear insertion is used.
- k = fnbr
- do while (k < lnbr)
- l = k
- k = k + 1
- nbr = invp(k)
-
- DO WHILE (fnbr < l)
- linvp = invp(l)
-
- if (deg(linvp) <= deg(nbr)) then
- exit
- endif
-
- invp(l+1) = linvp
- l = l-1
- ENDDO
-
- invp(l+1) = nbr
- enddo
- ENDIF
- enddo
- ENDDO
-
- ENDIF
-
- if (gsize > limit) then
- do i = limit + 1 , nbnodes
- node=invp(i)
- if (node /=0) mask(node) = 1
- enddo
- next_root = invp(limit +1)
- nspec_sub = limit
- else
- next_root = -1
- nspec_sub = gsize
- endif
-
-END subroutine Cut_McK
-
-
-!*******************************************************************************
-! Objective: computes the degrees of the nodes in the connected graph
-!
-! Parameters:
-! root the root node
-! nbnodes the number of nodes in the graph
-! nnz the graph size
-! xadj/adj the whole graph
-! mask Only nodes with mask == 0 are considered
-!
-! gsize the number of nodes in the connected graph
-! deg degree for all the nodes in the connected graph
-! level levelization of the connected graph
-!
-!*******************************************************************************
-
-subroutine degree( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, level )
-
- implicit none
-
-!--------------------------------------------------------------- Input Variables
- integer root, nbnodes, nnz
- integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
-
-!-------------------------------------------------------------- Output Variables
- integer gsize
- integer deg(nbnodes), level(nbnodes)
-
-!--------------------------------------------------------------- Local Variables
- integer i, j, ideg, lbegin, lvlend, lvsize, nxt, nbr, node
-
-! The sign of xadj(I) is used to indicate if node i has been considered
- xadj(root) = -xadj(root)
- level(1) = root
- nxt = 1
- lvlend = 0
- lvsize = 1
-
- DO WHILE (lvsize > 0)
- ! lbegin/lvlend points the begin/end of the present level
- lbegin = lvlend + 1
- lvlend = nxt
-
- ! Find the degrees of nodes in the present level and generate the next level
- DO i= lbegin, lvlend
- node = level(i)
- ideg = 0
- do j= ABS( xadj(node) ), ABS( xadj(node+1) )-1
- nbr = adj(j)
-
- if (mask(nbr) /= 0) then
- ideg = ideg + 1
-
- if (xadj(nbr) >= 0) then
- xadj(nbr) = -xadj(nbr)
- nxt = nxt + 1
- level(nxt) = nbr
- endif
- endif
- enddo
-
- deg(node) = ideg
- ENDDO
-
- !Compute the level size of the next level
- lvsize = nxt - lvlend
- ENDDO
-
- !Reset xadj to its correct sign
- do i = 1, nxt
- node = level(i)
- xadj(node) = -xadj(node)
- enddo
-
- gsize = nxt
-
-END subroutine degree
-
-!
-!-----------------------------------------------------------------------
-!
-
- subroutine permute_elements_real(array_to_permute,temp_array,perm,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: nspec
- integer, intent(in), dimension(nspec) :: perm
-
- real(kind=CUSTOM_REAL), intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
-
- integer old_ispec,new_ispec
-
-! copy the original array
- temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
-
- do old_ispec = 1,nspec
- new_ispec = perm(old_ispec)
- array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
- enddo
-
- end subroutine permute_elements_real
-
-!
-!-----------------------------------------------------------------------
-!
-
-!! DK DK added this for merged version
- subroutine permute_elements_xelm_yelm_zelm(array_to_permute,temp_array,perm,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: nspec
- integer, intent(in), dimension(nspec) :: perm
-
- real(kind=CUSTOM_REAL), intent(inout), dimension(NGNOD,nspec) :: array_to_permute,temp_array
-
- integer old_ispec,new_ispec
-
-! copy the original array
- temp_array(:,:) = array_to_permute(:,:)
-
- do old_ispec = 1,nspec
- new_ispec = perm(old_ispec)
- array_to_permute(:,new_ispec) = temp_array(:,old_ispec)
- enddo
-
- end subroutine permute_elements_xelm_yelm_zelm
-
-!
-!-----------------------------------------------------------------------
-!
-
-! implement permutation of elements for arrays of integer type
- subroutine permute_elements_integer(array_to_permute,temp_array,perm,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: nspec
- integer, intent(in), dimension(nspec) :: perm
-
- integer, intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
-
- integer old_ispec,new_ispec
-
-! copy the original array
- temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
-
- do old_ispec = 1,nspec
- new_ispec = perm(old_ispec)
- array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
- enddo
-
- end subroutine permute_elements_integer
-
-!
-!-----------------------------------------------------------------------
-!
-
-! implement permutation of elements for arrays of double precision type
- subroutine permute_elements_dble(array_to_permute,temp_array,perm,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: nspec
- integer, intent(in), dimension(nspec) :: perm
-
- double precision, intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
-
- integer old_ispec,new_ispec
-
-! copy the original array
- temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
-
- do old_ispec = 1,nspec
- new_ispec = perm(old_ispec)
- array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
- enddo
-
- end subroutine permute_elements_dble
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape2D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape2D.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape2D.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,160 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_shape2D(myrank,shape2D,dershape2D,xigll,yigll,NGLLA,NGLLB)
-
- implicit none
-
- include "constants.h"
-
-! generic routine that accepts any polynomial degree in each direction
-
- integer NGLLA,NGLLB,myrank
-
- double precision xigll(NGLLA)
- double precision yigll(NGLLB)
-
-! 2D shape functions and their derivatives
- double precision shape2D(NGNOD2D,NGLLA,NGLLB)
- double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
-
- integer i,j,ia
-
-! location of the nodes of the 2D quadrilateral elements
- double precision xi,eta
- double precision l1xi,l2xi,l3xi,l1eta,l2eta,l3eta
- double precision l1pxi,l2pxi,l3pxi,l1peta,l2peta,l3peta
-
-! for checking the 2D shape functions
- double precision sumshape,sumdershapexi,sumdershapeeta
-
-! check that the parameter file is correct
- if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes')
- if(NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes')
-
-! generate the 2D shape functions and their derivatives (9 nodes)
- do i=1,NGLLA
-
- xi=xigll(i)
-
- l1xi=HALF*xi*(xi-ONE)
- l2xi=ONE-xi**2
- l3xi=HALF*xi*(xi+ONE)
-
- l1pxi=xi-HALF
- l2pxi=-TWO*xi
- l3pxi=xi+HALF
-
- do j=1,NGLLB
-
- eta=yigll(j)
-
- l1eta=HALF*eta*(eta-ONE)
- l2eta=ONE-eta**2
- l3eta=HALF*eta*(eta+ONE)
-
- l1peta=eta-HALF
- l2peta=-TWO*eta
- l3peta=eta+HALF
-
-! corner nodes
-
- shape2D(1,i,j)=l1xi*l1eta
- shape2D(2,i,j)=l3xi*l1eta
- shape2D(3,i,j)=l3xi*l3eta
- shape2D(4,i,j)=l1xi*l3eta
-
- dershape2D(1,1,i,j)=l1pxi*l1eta
- dershape2D(1,2,i,j)=l3pxi*l1eta
- dershape2D(1,3,i,j)=l3pxi*l3eta
- dershape2D(1,4,i,j)=l1pxi*l3eta
-
- dershape2D(2,1,i,j)=l1xi*l1peta
- dershape2D(2,2,i,j)=l3xi*l1peta
- dershape2D(2,3,i,j)=l3xi*l3peta
- dershape2D(2,4,i,j)=l1xi*l3peta
-
-! midside nodes
-
- shape2D(5,i,j)=l2xi*l1eta
- shape2D(6,i,j)=l3xi*l2eta
- shape2D(7,i,j)=l2xi*l3eta
- shape2D(8,i,j)=l1xi*l2eta
-
- dershape2D(1,5,i,j)=l2pxi*l1eta
- dershape2D(1,6,i,j)=l3pxi*l2eta
- dershape2D(1,7,i,j)=l2pxi*l3eta
- dershape2D(1,8,i,j)=l1pxi*l2eta
-
- dershape2D(2,5,i,j)=l2xi*l1peta
- dershape2D(2,6,i,j)=l3xi*l2peta
- dershape2D(2,7,i,j)=l2xi*l3peta
- dershape2D(2,8,i,j)=l1xi*l2peta
-
-! center node
-
- shape2D(9,i,j)=l2xi*l2eta
-
- dershape2D(1,9,i,j)=l2pxi*l2eta
- dershape2D(2,9,i,j)=l2xi*l2peta
-
- enddo
- enddo
-
-! check the 2D shape functions
- do i=1,NGLLA
- do j=1,NGLLB
-
- sumshape=ZERO
-
- sumdershapexi=ZERO
- sumdershapeeta=ZERO
-
- do ia=1,NGNOD2D
-
- sumshape=sumshape+shape2D(ia,i,j)
-
- sumdershapexi=sumdershapexi+dershape2D(1,ia,i,j)
- sumdershapeeta=sumdershapeeta+dershape2D(2,ia,i,j)
-
- enddo
-
-! the sum of the shape functions should be 1
- if(abs(sumshape-ONE)>TINYVAL) call exit_MPI(myrank,'error in 2D shape functions')
-
-! the sum of the derivatives of the shape functions should be 0
- if(abs(sumdershapexi)>TINYVAL) &
- call exit_MPI(myrank,'error in xi derivatives of 2D shape function')
-
- if(abs(sumdershapeeta)>TINYVAL) &
- call exit_MPI(myrank,'error in eta derivatives of 2D shape function')
-
- enddo
- enddo
-
- end subroutine get_shape2D
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape3D.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape3D.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,268 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
-
- implicit none
-
- include "constants.h"
-
- integer myrank
-
-! Gauss-Lobatto-Legendre points of integration
- double precision xigll(NGLLX)
- double precision yigll(NGLLY)
- double precision zigll(NGLLZ)
-
-! 3D shape functions and their derivatives
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
- double precision dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
-
- integer i,j,k,ia
-
-! location of the nodes of the 3D quadrilateral elements
- double precision xi,eta,gamma
- double precision l1xi,l2xi,l3xi,l1eta,l2eta,l3eta,l1gamma,l2gamma,l3gamma
- double precision l1pxi,l2pxi,l3pxi,l1peta,l2peta,l3peta,l1pgamma,l2pgamma,l3pgamma
-
-! for checking the 3D shape functions
- double precision sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
-
-! check that the parameter file is correct
- if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes')
-
-! generate the 3D shape functions and their derivatives (27 nodes)
- do i=1,NGLLX
-
- xi=xigll(i)
-
- l1xi=HALF*xi*(xi-ONE)
- l2xi=ONE-xi**2
- l3xi=HALF*xi*(xi+ONE)
-
- l1pxi=xi-HALF
- l2pxi=-TWO*xi
- l3pxi=xi+HALF
-
- do j=1,NGLLY
-
- eta=yigll(j)
-
- l1eta=HALF*eta*(eta-ONE)
- l2eta=ONE-eta**2
- l3eta=HALF*eta*(eta+ONE)
-
- l1peta=eta-HALF
- l2peta=-TWO*eta
- l3peta=eta+HALF
-
- do k=1,NGLLZ
-
- gamma=zigll(k)
-
- l1gamma=HALF*gamma*(gamma-ONE)
- l2gamma=ONE-gamma**2
- l3gamma=HALF*gamma*(gamma+ONE)
-
- l1pgamma=gamma-HALF
- l2pgamma=-TWO*gamma
- l3pgamma=gamma+HALF
-
-! corner nodes
-
- shape3D(1,i,j,k)=l1xi*l1eta*l1gamma
- shape3D(2,i,j,k)=l3xi*l1eta*l1gamma
- shape3D(3,i,j,k)=l3xi*l3eta*l1gamma
- shape3D(4,i,j,k)=l1xi*l3eta*l1gamma
- shape3D(5,i,j,k)=l1xi*l1eta*l3gamma
- shape3D(6,i,j,k)=l3xi*l1eta*l3gamma
- shape3D(7,i,j,k)=l3xi*l3eta*l3gamma
- shape3D(8,i,j,k)=l1xi*l3eta*l3gamma
-
- dershape3D(1,1,i,j,k)=l1pxi*l1eta*l1gamma
- dershape3D(1,2,i,j,k)=l3pxi*l1eta*l1gamma
- dershape3D(1,3,i,j,k)=l3pxi*l3eta*l1gamma
- dershape3D(1,4,i,j,k)=l1pxi*l3eta*l1gamma
- dershape3D(1,5,i,j,k)=l1pxi*l1eta*l3gamma
- dershape3D(1,6,i,j,k)=l3pxi*l1eta*l3gamma
- dershape3D(1,7,i,j,k)=l3pxi*l3eta*l3gamma
- dershape3D(1,8,i,j,k)=l1pxi*l3eta*l3gamma
-
- dershape3D(2,1,i,j,k)=l1xi*l1peta*l1gamma
- dershape3D(2,2,i,j,k)=l3xi*l1peta*l1gamma
- dershape3D(2,3,i,j,k)=l3xi*l3peta*l1gamma
- dershape3D(2,4,i,j,k)=l1xi*l3peta*l1gamma
- dershape3D(2,5,i,j,k)=l1xi*l1peta*l3gamma
- dershape3D(2,6,i,j,k)=l3xi*l1peta*l3gamma
- dershape3D(2,7,i,j,k)=l3xi*l3peta*l3gamma
- dershape3D(2,8,i,j,k)=l1xi*l3peta*l3gamma
-
- dershape3D(3,1,i,j,k)=l1xi*l1eta*l1pgamma
- dershape3D(3,2,i,j,k)=l3xi*l1eta*l1pgamma
- dershape3D(3,3,i,j,k)=l3xi*l3eta*l1pgamma
- dershape3D(3,4,i,j,k)=l1xi*l3eta*l1pgamma
- dershape3D(3,5,i,j,k)=l1xi*l1eta*l3pgamma
- dershape3D(3,6,i,j,k)=l3xi*l1eta*l3pgamma
- dershape3D(3,7,i,j,k)=l3xi*l3eta*l3pgamma
- dershape3D(3,8,i,j,k)=l1xi*l3eta*l3pgamma
-
-! midside nodes
-
- shape3D(9,i,j,k)=l2xi*l1eta*l1gamma
- shape3D(10,i,j,k)=l3xi*l2eta*l1gamma
- shape3D(11,i,j,k)=l2xi*l3eta*l1gamma
- shape3D(12,i,j,k)=l1xi*l2eta*l1gamma
- shape3D(13,i,j,k)=l1xi*l1eta*l2gamma
- shape3D(14,i,j,k)=l3xi*l1eta*l2gamma
- shape3D(15,i,j,k)=l3xi*l3eta*l2gamma
- shape3D(16,i,j,k)=l1xi*l3eta*l2gamma
- shape3D(17,i,j,k)=l2xi*l1eta*l3gamma
- shape3D(18,i,j,k)=l3xi*l2eta*l3gamma
- shape3D(19,i,j,k)=l2xi*l3eta*l3gamma
- shape3D(20,i,j,k)=l1xi*l2eta*l3gamma
-
- dershape3D(1,9,i,j,k)=l2pxi*l1eta*l1gamma
- dershape3D(1,10,i,j,k)=l3pxi*l2eta*l1gamma
- dershape3D(1,11,i,j,k)=l2pxi*l3eta*l1gamma
- dershape3D(1,12,i,j,k)=l1pxi*l2eta*l1gamma
- dershape3D(1,13,i,j,k)=l1pxi*l1eta*l2gamma
- dershape3D(1,14,i,j,k)=l3pxi*l1eta*l2gamma
- dershape3D(1,15,i,j,k)=l3pxi*l3eta*l2gamma
- dershape3D(1,16,i,j,k)=l1pxi*l3eta*l2gamma
- dershape3D(1,17,i,j,k)=l2pxi*l1eta*l3gamma
- dershape3D(1,18,i,j,k)=l3pxi*l2eta*l3gamma
- dershape3D(1,19,i,j,k)=l2pxi*l3eta*l3gamma
- dershape3D(1,20,i,j,k)=l1pxi*l2eta*l3gamma
-
- dershape3D(2,9,i,j,k)=l2xi*l1peta*l1gamma
- dershape3D(2,10,i,j,k)=l3xi*l2peta*l1gamma
- dershape3D(2,11,i,j,k)=l2xi*l3peta*l1gamma
- dershape3D(2,12,i,j,k)=l1xi*l2peta*l1gamma
- dershape3D(2,13,i,j,k)=l1xi*l1peta*l2gamma
- dershape3D(2,14,i,j,k)=l3xi*l1peta*l2gamma
- dershape3D(2,15,i,j,k)=l3xi*l3peta*l2gamma
- dershape3D(2,16,i,j,k)=l1xi*l3peta*l2gamma
- dershape3D(2,17,i,j,k)=l2xi*l1peta*l3gamma
- dershape3D(2,18,i,j,k)=l3xi*l2peta*l3gamma
- dershape3D(2,19,i,j,k)=l2xi*l3peta*l3gamma
- dershape3D(2,20,i,j,k)=l1xi*l2peta*l3gamma
-
- dershape3D(3,9,i,j,k)=l2xi*l1eta*l1pgamma
- dershape3D(3,10,i,j,k)=l3xi*l2eta*l1pgamma
- dershape3D(3,11,i,j,k)=l2xi*l3eta*l1pgamma
- dershape3D(3,12,i,j,k)=l1xi*l2eta*l1pgamma
- dershape3D(3,13,i,j,k)=l1xi*l1eta*l2pgamma
- dershape3D(3,14,i,j,k)=l3xi*l1eta*l2pgamma
- dershape3D(3,15,i,j,k)=l3xi*l3eta*l2pgamma
- dershape3D(3,16,i,j,k)=l1xi*l3eta*l2pgamma
- dershape3D(3,17,i,j,k)=l2xi*l1eta*l3pgamma
- dershape3D(3,18,i,j,k)=l3xi*l2eta*l3pgamma
- dershape3D(3,19,i,j,k)=l2xi*l3eta*l3pgamma
- dershape3D(3,20,i,j,k)=l1xi*l2eta*l3pgamma
-
-! side center nodes
-
- shape3D(21,i,j,k)=l2xi*l2eta*l1gamma
- shape3D(22,i,j,k)=l2xi*l1eta*l2gamma
- shape3D(23,i,j,k)=l3xi*l2eta*l2gamma
- shape3D(24,i,j,k)=l2xi*l3eta*l2gamma
- shape3D(25,i,j,k)=l1xi*l2eta*l2gamma
- shape3D(26,i,j,k)=l2xi*l2eta*l3gamma
-
- dershape3D(1,21,i,j,k)=l2pxi*l2eta*l1gamma
- dershape3D(1,22,i,j,k)=l2pxi*l1eta*l2gamma
- dershape3D(1,23,i,j,k)=l3pxi*l2eta*l2gamma
- dershape3D(1,24,i,j,k)=l2pxi*l3eta*l2gamma
- dershape3D(1,25,i,j,k)=l1pxi*l2eta*l2gamma
- dershape3D(1,26,i,j,k)=l2pxi*l2eta*l3gamma
-
- dershape3D(2,21,i,j,k)=l2xi*l2peta*l1gamma
- dershape3D(2,22,i,j,k)=l2xi*l1peta*l2gamma
- dershape3D(2,23,i,j,k)=l3xi*l2peta*l2gamma
- dershape3D(2,24,i,j,k)=l2xi*l3peta*l2gamma
- dershape3D(2,25,i,j,k)=l1xi*l2peta*l2gamma
- dershape3D(2,26,i,j,k)=l2xi*l2peta*l3gamma
-
- dershape3D(3,21,i,j,k)=l2xi*l2eta*l1pgamma
- dershape3D(3,22,i,j,k)=l2xi*l1eta*l2pgamma
- dershape3D(3,23,i,j,k)=l3xi*l2eta*l2pgamma
- dershape3D(3,24,i,j,k)=l2xi*l3eta*l2pgamma
- dershape3D(3,25,i,j,k)=l1xi*l2eta*l2pgamma
- dershape3D(3,26,i,j,k)=l2xi*l2eta*l3pgamma
-
-! center node
-
- shape3D(27,i,j,k)=l2xi*l2eta*l2gamma
-
- dershape3D(1,27,i,j,k)=l2pxi*l2eta*l2gamma
- dershape3D(2,27,i,j,k)=l2xi*l2peta*l2gamma
- dershape3D(3,27,i,j,k)=l2xi*l2eta*l2pgamma
-
- enddo
- enddo
- enddo
-
-! check the shape functions
- do i=1,NGLLX
- do j=1,NGLLY
- do k=1,NGLLZ
-
- sumshape=ZERO
-
- sumdershapexi=ZERO
- sumdershapeeta=ZERO
- sumdershapegamma=ZERO
-
- do ia=1,NGNOD
-
- sumshape=sumshape+shape3D(ia,i,j,k)
-
- sumdershapexi=sumdershapexi+dershape3D(1,ia,i,j,k)
- sumdershapeeta=sumdershapeeta+dershape3D(2,ia,i,j,k)
- sumdershapegamma=sumdershapegamma+dershape3D(3,ia,i,j,k)
-
- enddo
-
-! the sum of the shape functions should be 1
- if(abs(sumshape-ONE) > TINYVAL) call exit_MPI(myrank,'error in 3D shape functions')
-
-! the sum of the derivatives of the shape functions should be 0
- if(abs(sumdershapexi) > TINYVAL) &
- call exit_MPI(myrank,'error in xi derivatives of 3D shape function')
-
- if(abs(sumdershapeeta) > TINYVAL) &
- call exit_MPI(myrank,'error in eta derivatives of 3D shape function')
-
- if(abs(sumdershapegamma) > TINYVAL) &
- call exit_MPI(myrank,'error in gamma derivatives of 3D shape function')
-
- enddo
- enddo
- enddo
-
- end subroutine get_shape3D
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_value_parameters.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_value_parameters.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,84 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_value_integer(value_to_get, name, default_value)
-
- implicit none
-
- integer value_to_get, default_value
- character(len=*) name
-
- call unused_string(name)
-
- value_to_get = default_value
-
- end subroutine get_value_integer
-
-!--------------------
-
- subroutine get_value_double_precision(value_to_get, name, default_value)
-
- implicit none
-
- double precision value_to_get, default_value
- character(len=*) name
-
- call unused_string(name)
-
- value_to_get = default_value
-
- end subroutine get_value_double_precision
-
-!--------------------
-
- subroutine get_value_logical(value_to_get, name, default_value)
-
- implicit none
-
- logical value_to_get, default_value
- character(len=*) name
-
- call unused_string(name)
-
- value_to_get = default_value
-
- end subroutine get_value_logical
-
-!--------------------
-
- subroutine get_value_string(value_to_get, name, default_value)
-
- implicit none
-
- character(len=*) value_to_get, default_value
- character(len=*) name
-
- call unused_string(name)
-
- value_to_get = default_value
-
- end subroutine get_value_string
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/gll_library.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/gll_library.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/gll_library.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,529 +0,0 @@
-
-!=======================================================================
-!
-! Library to compute the Gauss-Lobatto-Legendre points and weights
-! Based on Gauss-Lobatto routines from M.I.T.
-! Department of Mechanical Engineering
-!
-!=======================================================================
-
- double precision function endw1(n,alpha,beta)
-
- implicit none
-
- integer n
- double precision alpha,beta
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
- double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
- double precision, external :: gammaf
- integer i
-
- f3 = zero
- apb = alpha+beta
- if (n == 0) then
- endw1 = zero
- return
- endif
- f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
- f1 = f1*(apb+two)*two**(apb+two)/two
- if (n == 1) then
- endw1 = f1
- return
- endif
- fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
- fint1 = fint1*two**(apb+two)
- fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
- fint2 = fint2*two**(apb+three)
- f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
- if (n == 2) then
- endw1 = f2
- return
- endif
- do i=3,n
- di = dble(i-1)
- abn = alpha+beta+di
- abnn = abn+di
- a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
- a2 = (two*(alpha-beta))/(abnn*(abnn+two))
- a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
- f3 = -(a2*f2+a1*f1)/a3
- f1 = f2
- f2 = f3
- enddo
- endw1 = f3
-
- end function endw1
-
-!
-!=======================================================================
-!
-
- double precision function endw2(n,alpha,beta)
-
- implicit none
-
- integer n
- double precision alpha,beta
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
- double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
- double precision, external :: gammaf
- integer i
-
- apb = alpha+beta
- f3 = zero
- if (n == 0) then
- endw2 = zero
- return
- endif
- f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
- f1 = f1*(apb+two)*two**(apb+two)/two
- if (n == 1) then
- endw2 = f1
- return
- endif
- fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
- fint1 = fint1*two**(apb+two)
- fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
- fint2 = fint2*two**(apb+three)
- f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
- if (n == 2) then
- endw2 = f2
- return
- endif
- do i=3,n
- di = dble(i-1)
- abn = alpha+beta+di
- abnn = abn+di
- a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
- a2 = (two*(alpha-beta))/(abnn*(abnn+two))
- a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
- f3 = -(a2*f2+a1*f1)/a3
- f1 = f2
- f2 = f3
- enddo
- endw2 = f3
-
- end function endw2
-
-!
-!=======================================================================
-!
-
- double precision function gammaf (x)
-
- implicit none
-
- double precision, parameter :: pi = 3.141592653589793d0
-
- double precision x
-
- double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
-
- gammaf = one
-
- if (x == -half) gammaf = -two*dsqrt(pi)
- if (x == half) gammaf = dsqrt(pi)
- if (x == one ) gammaf = one
- if (x == two ) gammaf = one
- if (x == 1.5d0) gammaf = dsqrt(pi)/2.d0
- if (x == 2.5d0) gammaf = 1.5d0*dsqrt(pi)/2.d0
- if (x == 3.5d0) gammaf = 2.5d0*1.5d0*dsqrt(pi)/2.d0
- if (x == 3.d0 ) gammaf = 2.d0
- if (x == 4.d0 ) gammaf = 6.d0
- if (x == 5.d0 ) gammaf = 24.d0
- if (x == 6.d0 ) gammaf = 120.d0
-
- end function gammaf
-
-!
-!=====================================================================
-!
-
- subroutine jacg (xjac,np,alpha,beta)
-
-!=======================================================================
-!
-! computes np Gauss points, which are the zeros of the
-! Jacobi polynomial with parameters alpha and beta
-!
-! .alpha = beta = 0.0 -> Legendre points
-! .alpha = beta = -0.5 -> Chebyshev points
-!
-!=======================================================================
-
- implicit none
-
- integer np
- double precision alpha,beta
- double precision xjac(np)
-
- integer k,j,i,jmin,jm,n
- double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
- double precision p,pd,pm1,pdm1,pm2,pdm2
-
- integer, parameter :: K_MAX_ITER = 10
- double precision, parameter :: zero = 0.d0, eps = 1.0d-12
-
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- xlast = 0.d0
- n = np-1
- dth = 4.d0*datan(1.d0)/(2.d0*dble(n)+2.d0)
- p = 0.d0
- pd = 0.d0
- jmin = 0
- do j=1,np
- if(j == 1) then
- x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
- else
- x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
- x2 = xlast
- x = (x1+x2)/2.d0
- endif
- do k=1,K_MAX_ITER
- call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
- recsum = 0.d0
- jm = j-1
- do i=1,jm
- recsum = recsum+1.d0/(x-xjac(np-i+1))
- enddo
- delx = -p/(pd-recsum*p)
- x = x+delx
- if(abs(delx) < eps) goto 31
- enddo
- 31 continue
- xjac(np-j+1) = x
- xlast = x
- enddo
- do i=1,np
- xmin = 2.d0
- do j=i,np
- if(xjac(j) < xmin) then
- xmin = xjac(j)
- jmin = j
- endif
- enddo
- if(jmin /= i) then
- swap = xjac(i)
- xjac(i) = xjac(jmin)
- xjac(jmin) = swap
- endif
- enddo
-
- end subroutine jacg
-
-!
-!=====================================================================
-!
-
- subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
-
-!=======================================================================
-!
-! Computes the Jacobi polynomial of degree n and its derivative at x
-!
-!=======================================================================
-
- implicit none
-
- double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
- integer n
-
- double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
- integer k
-
- apb = alp+bet
- poly = 1.d0
- pder = 0.d0
- psave = 0.d0
- pdsave = 0.d0
-
- if (n == 0) return
-
- polyl = poly
- pderl = pder
- poly = (alp-bet+(apb+2.d0)*x)/2.d0
- pder = (apb+2.d0)/2.d0
- if (n == 1) return
-
- do k=2,n
- dk = dble(k)
- a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
- a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
- b3 = (2.d0*dk+apb-2.d0)
- a3 = b3*(b3+1.d0)*(b3+2.d0)
- a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
- polyn = ((a2+a3*x)*poly-a4*polyl)/a1
- pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
- psave = polyl
- pdsave = pderl
- polyl = poly
- poly = polyn
- pderl = pder
- pder = pdern
- enddo
-
- polym1 = polyl
- pderm1 = pderl
- polym2 = psave
- pderm2 = pdsave
-
- end subroutine jacobf
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision FUNCTION PNDLEG (Z,N)
-
-!------------------------------------------------------------------------
-!
-! Compute the derivative of the Nth order Legendre polynomial at Z.
-! Based on the recursion formula for the Legendre polynomials.
-!
-!------------------------------------------------------------------------
- implicit none
-
- double precision z
- integer n
-
- double precision P1,P2,P1D,P2D,P3D,FK,P3
- integer k
-
- P1 = 1.d0
- P2 = Z
- P1D = 0.d0
- P2D = 1.d0
- P3D = 1.d0
-
- do K = 1, N-1
- FK = dble(K)
- P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
- P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
- P1 = P2
- P2 = P3
- P1D = P2D
- P2D = P3D
- enddo
-
- PNDLEG = P3D
-
- end function pndleg
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision FUNCTION PNLEG (Z,N)
-
-!------------------------------------------------------------------------
-!
-! Compute the value of the Nth order Legendre polynomial at Z.
-! Based on the recursion formula for the Legendre polynomials.
-!
-!------------------------------------------------------------------------
- implicit none
-
- double precision z
- integer n
-
- double precision P1,P2,P3,FK
- integer k
-
- P1 = 1.d0
- P2 = Z
- P3 = P2
-
- do K = 1, N-1
- FK = dble(K)
- P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
- P1 = P2
- P2 = P3
- enddo
-
- PNLEG = P3
-
- end function pnleg
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision function pnormj (n,alpha,beta)
-
- implicit none
-
- double precision alpha,beta
- integer n
-
- double precision one,two,dn,const,prod,dindx,frac
- double precision, external :: gammaf
- integer i
-
- one = 1.d0
- two = 2.d0
- dn = dble(n)
- const = alpha+beta+one
-
- if (n <= 1) then
- prod = gammaf(dn+alpha)*gammaf(dn+beta)
- prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
- pnormj = prod * two**const/(two*dn+const)
- return
- endif
-
- prod = gammaf(alpha+one)*gammaf(beta+one)
- prod = prod/(two*(one+const)*gammaf(const+one))
- prod = prod*(one+alpha)*(two+alpha)
- prod = prod*(one+beta)*(two+beta)
-
- do i=3,n
- dindx = dble(i)
- frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
- prod = prod*frac
- enddo
-
- pnormj = prod * two**const/(two*dn+const)
-
- end function pnormj
-
-!
-!------------------------------------------------------------------------
-!
-
- subroutine zwgjd(z,w,np,alpha,beta)
-
-!=======================================================================
-!
-! Z w g j d : Generate np Gauss-Jacobi points and weights
-! associated with Jacobi polynomial of degree n = np-1
-!
-! Note : Coefficients alpha and beta must be greater than -1.
-! ----
-!=======================================================================
-
- implicit none
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
-
- integer np
- double precision z(np),w(np)
- double precision alpha,beta
-
- integer n,np1,np2,i
- double precision p,pd,pm1,pdm1,pm2,pdm2
- double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
- double precision, external :: gammaf,pnormj
-
- pd = zero
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- n = np-1
- apb = alpha+beta
- p = zero
- pdm1 = zero
-
- if (np <= 0) stop 'minimum number of Gauss points is 1'
-
- if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
-
- if (np == 1) then
- z(1) = (beta-alpha)/(apb+two)
- w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
- return
- endif
-
- call jacg(z,np,alpha,beta)
-
- np1 = n+1
- np2 = n+2
- dnp1 = dble(np1)
- dnp2 = dble(np2)
- fac1 = dnp1+alpha+beta+one
- fac2 = fac1+dnp1
- fac3 = fac2+one
- fnorm = pnormj(np1,alpha,beta)
- rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
- do i=1,np
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
- w(i) = -rcoef/(p*pdm1)
- enddo
-
- end subroutine zwgjd
-
-!
-!------------------------------------------------------------------------
-!
-
- subroutine zwgljd(z,w,np,alpha,beta)
-
-!=======================================================================
-!
-! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
-! ----------- weights associated with Jacobi polynomials of degree
-! n = np-1.
-!
-! Note : alpha and beta coefficients must be greater than -1.
-! Legendre polynomials are special case of Jacobi polynomials
-! just by setting alpha and beta to 0.
-!
-!=======================================================================
-
- implicit none
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
-
- integer np
- double precision alpha,beta
- double precision z(np), w(np)
-
- integer n,nm1,i
- double precision p,pd,pm1,pdm1,pm2,pdm2
- double precision alpg,betg
- double precision, external :: endw1,endw2
-
- p = zero
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- n = np-1
- nm1 = n-1
- pd = zero
-
- if (np <= 1) stop 'minimum number of Gauss-Lobatto points is 2'
-
-! with spectral elements, use at least 3 points
- if (np <= 2) stop 'minimum number of Gauss-Lobatto points for the SEM is 3'
-
- if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
-
- if (nm1 > 0) then
- alpg = alpha+one
- betg = beta+one
- call zwgjd(z(2),w(2),nm1,alpg,betg)
- endif
-
- z(1) = - one
- z(np) = one
-
- do i=2,np-1
- w(i) = w(i)/(one-z(i)**2)
- enddo
-
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
- w(1) = endw1(n,alpha,beta)/(two*pd)
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
- w(np) = endw2(n,alpha,beta)/(two*pd)
-
- end subroutine zwgljd
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/go_mesher_solver_lsf_globe.bash
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/go_mesher_solver_lsf_globe.bash 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/go_mesher_solver_lsf_globe.bash 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,42 +0,0 @@
-#!/bin/bash
-#BSUB -o OUTPUT_FILES/%J.o
-#BSUB -a mpich_gm
-#BSUB -J go_mesher_solver_lsf
-
-if [ -z $USER ]; then
- echo "could not run go_mesher_solver_...bash as no USER env is set"
- exit 2
-fi
-
-# script to run the mesher and the solver
-
-# read DATA/Par_file to get information about the run
-
-# compute total number of nodes needed
-NPROC_XI=`grep NPROC_XI DATA/Par_file | cut -d = -f 2 `
-NPROC_ETA=`grep NPROC_ETA DATA/Par_file | cut -d = -f 2`
-NCHUNKS=`grep NCHUNKS DATA/Par_file | cut -d = -f 2 `
-
-# total number of nodes is the product of the values read
-numnodes=$(( $NCHUNKS * $NPROC_XI * $NPROC_ETA ))
-
-rm -r -f OUTPUT_FILES
-mkdir OUTPUT_FILES
-
-# obtain lsf job information
-echo "$LSB_MCPU_HOSTS" > OUTPUT_FILES/lsf_machines
-echo "$LSB_JOBID" > OUTPUT_FILES/jobid
-
-./remap_lsf_machines.pl OUTPUT_FILES/lsf_machines >OUTPUT_FILES/machines
-
-echo starting MPI mesher on $numnodes processors
-echo " "
-echo starting run in current directory $PWD
-echo " "
-
-sleep 2
-
-#### use this on LSF
-mpirun.lsf --gm-no-shmem --gm-copy-env $PWD/xmeshfem3D
-####mpirun.lsf --gm-no-shmem --gm-copy-env $PWD/xspecfem3D
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/hex_nodes.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/hex_nodes.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/hex_nodes.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,160 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 hex_nodes(iaddx,iaddy,iaddz)
-
- implicit none
-
- include "constants.h"
-
-! topology of the elements
- integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
-
-! define the topology of the hexahedral elements
-
-! the topology of the nodes is described in UTILS/chunk_notes_scanned/numbering_convention_27_nodes.tif
-
- if(NGNOD /= 27) stop 'elements should have 27 control nodes'
-
-! corner nodes
-
- iaddx(1) = 0
- iaddy(1) = 0
- iaddz(1) = 0
-
- iaddx(2) = 2
- iaddy(2) = 0
- iaddz(2) = 0
-
- iaddx(3) = 2
- iaddy(3) = 2
- iaddz(3) = 0
-
- iaddx(4) = 0
- iaddy(4) = 2
- iaddz(4) = 0
-
- iaddx(5) = 0
- iaddy(5) = 0
- iaddz(5) = 2
-
- iaddx(6) = 2
- iaddy(6) = 0
- iaddz(6) = 2
-
- iaddx(7) = 2
- iaddy(7) = 2
- iaddz(7) = 2
-
- iaddx(8) = 0
- iaddy(8) = 2
- iaddz(8) = 2
-
-! midside nodes (nodes located in the middle of an edge)
-
- iaddx(9) = 1
- iaddy(9) = 0
- iaddz(9) = 0
-
- iaddx(10) = 2
- iaddy(10) = 1
- iaddz(10) = 0
-
- iaddx(11) = 1
- iaddy(11) = 2
- iaddz(11) = 0
-
- iaddx(12) = 0
- iaddy(12) = 1
- iaddz(12) = 0
-
- iaddx(13) = 0
- iaddy(13) = 0
- iaddz(13) = 1
-
- iaddx(14) = 2
- iaddy(14) = 0
- iaddz(14) = 1
-
- iaddx(15) = 2
- iaddy(15) = 2
- iaddz(15) = 1
-
- iaddx(16) = 0
- iaddy(16) = 2
- iaddz(16) = 1
-
- iaddx(17) = 1
- iaddy(17) = 0
- iaddz(17) = 2
-
- iaddx(18) = 2
- iaddy(18) = 1
- iaddz(18) = 2
-
- iaddx(19) = 1
- iaddy(19) = 2
- iaddz(19) = 2
-
- iaddx(20) = 0
- iaddy(20) = 1
- iaddz(20) = 2
-
-! side center nodes (nodes located in the middle of a face)
-
- iaddx(21) = 1
- iaddy(21) = 1
- iaddz(21) = 0
-
- iaddx(22) = 1
- iaddy(22) = 0
- iaddz(22) = 1
-
- iaddx(23) = 2
- iaddy(23) = 1
- iaddz(23) = 1
-
- iaddx(24) = 1
- iaddy(24) = 2
- iaddz(24) = 1
-
- iaddx(25) = 0
- iaddy(25) = 1
- iaddz(25) = 1
-
- iaddx(26) = 1
- iaddy(26) = 1
- iaddz(26) = 2
-
-! center node (barycenter of the eight corners)
-
- iaddx(27) = 1
- iaddy(27) = 1
- iaddz(27) = 1
-
- end subroutine hex_nodes
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/intgrl.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/intgrl.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/intgrl.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,185 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 intgrl(sum,r,nir,ner,f,s1,s2,s3)
-
-! Computes the integral of f[i]*r[i]*r[i] from i=nir to i=ner for
-! radii values as in model PREM_an640
-
- implicit none
-
-! Argument variables
- integer ner,nir
- double precision f(640),r(640),s1(640),s2(640)
- double precision s3(640),sum
-
-! Local variables
- integer i,j,n,kdis(28)
- integer ndis,nir1
- double precision rji,yprime(640)
-
- double precision, parameter :: third = 1.0d0/3.0d0
- double precision, parameter :: fifth = 1.0d0/5.0d0
- double precision, parameter :: sixth = 1.0d0/6.0d0
-
- data kdis/163,323,336,517,530,540,565,590,609,619,626,633,16*0/
-
- ndis = 12
- n = 640
-
- call deriv(f,yprime,n,r,ndis,kdis,s1,s2,s3)
- nir1 = nir + 1
- sum = 0.0d0
- do i=nir1,ner
- j = i-1
- rji = r(i) - r(j)
- sum=sum+r(j)*r(j)*rji*(f(j)+rji*(.50d0*s1(j)+rji*(third*s2(j)+rji* &
- .250d0*s3(j))))+2.0d0*r(j)*rji*rji*(.50d0*f(j)+rji*(third*s1(j)+rji* &
- (.250d0*s2(j)+rji*fifth*s3(j))))+rji*rji*rji*(third*f(j)+rji* &
- (.250d0*s1(j)+rji*(fifth*s2(j)+rji*sixth*s3(j))))
- enddo
-
- end subroutine intgrl
-
-! -------------------------------
-
- subroutine deriv(y,yprime,n,r,ndis,kdis,s1,s2,s3)
-
- implicit none
-
-! Argument variables
- integer kdis(28),n,ndis
- double precision r(n),s1(n),s2(n),s3(n)
- double precision y(n),yprime(n)
-
-! Local variables
- integer i,j,j1,j2
- integer k,nd,ndp
- double precision a0,b0,b1
- double precision f(3,1000),h,h2,h2a
- double precision h2b,h3a,ha,s13
- double precision s21,s32,yy(3)
-
- yy(1) = 0.d0
- yy(2) = 0.d0
- yy(3) = 0.d0
-
- ndp=ndis+1
- do 3 nd=1,ndp
- if(nd == 1) goto 4
- if(nd == ndp) goto 5
- j1=kdis(nd-1)+1
- j2=kdis(nd)-2
- goto 6
- 4 j1=1
- j2=kdis(1)-2
- goto 6
- 5 j1=kdis(ndis)+1
- j2=n-2
- 6 if((j2+1-j1)>0) goto 11
- j2=j2+2
- yy(1)=(y(j2)-y(j1))/(r(j2)-r(j1))
- s1(j1)=yy(1)
- s1(j2)=yy(1)
- s2(j1)=yy(2)
- s2(j2)=yy(2)
- s3(j1)=yy(3)
- s3(j2)=yy(3)
- goto 3
- 11 a0=0.0d0
- if(j1 == 1) goto 7
- h=r(j1+1)-r(j1)
- h2=r(j1+2)-r(j1)
- yy(1)=h*h2*(h2-h)
- h=h*h
- h2=h2*h2
- b0=(y(j1)*(h-h2)+y(j1+1)*h2-y(j1+2)*h)/yy(1)
- goto 8
- 7 b0=0.0d0
- 8 b1=b0
-
- if(j2 > 1000) stop 'error in subroutine deriv for j2'
-
- do i=j1,j2
- h=r(i+1)-r(i)
- yy(1)=y(i+1)-y(i)
- h2=h*h
- ha=h-a0
- h2a=h-2.0d0*a0
- h3a=2.0d0*h-3.0d0*a0
- h2b=h2*b0
- s1(i)=h2/ha
- s2(i)=-ha/(h2a*h2)
- s3(i)=-h*h2a/h3a
- f(1,i)=(yy(1)-h*b0)/(h*ha)
- f(2,i)=(h2b-yy(1)*(2.0d0*h-a0))/(h*h2*h2a)
- f(3,i)=-(h2b-3.0d0*yy(1)*ha)/(h*h3a)
- a0=s3(i)
- b0=f(3,i)
- enddo
-
- i=j2+1
- h=r(i+1)-r(i)
- yy(1)=y(i+1)-y(i)
- h2=h*h
- ha=h-a0
- h2a=h*ha
- h2b=h2*b0-yy(1)*(2.d0*h-a0)
- s1(i)=h2/ha
- f(1,i)=(yy(1)-h*b0)/h2a
- ha=r(j2)-r(i+1)
- yy(1)=-h*ha*(ha+h)
- ha=ha*ha
- yy(1)=(y(i+1)*(h2-ha)+y(i)*ha-y(j2)*h2)/yy(1)
- s3(i)=(yy(1)*h2a+h2b)/(h*h2*(h-2.0d0*a0))
- s13=s1(i)*s3(i)
- s2(i)=f(1,i)-s13
-
- do j=j1,j2
- k=i-1
- s32=s3(k)*s2(i)
- s1(i)=f(3,k)-s32
- s21=s2(k)*s1(i)
- s3(k)=f(2,k)-s21
- s13=s1(k)*s3(k)
- s2(k)=f(1,k)-s13
- i=k
- enddo
-
- s1(i)=b1
- j2=j2+2
- s1(j2)=yy(1)
- s2(j2)=yy(2)
- s3(j2)=yy(3)
- 3 continue
-
- do i=1,n
- yprime(i)=s1(i)
- enddo
-
- end subroutine deriv
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/jp3d1994_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/jp3d1994_model.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/jp3d1994_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,1265 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-
-!=====================================================================
-!
-! Last Time Modified by Min Chen, Caltech, 03/14/2008
-!
-! Program ----- veljp3d.f -----
-!
-! This program is used to calculate 3-D P-wave velocity
-! distribution beneath the Japan Islands which is obtained
-! by a simultaneous inversion of arrival time data from local,
-! regional and teleseismic events. For details, see "Deep
-! structure of the Japan subduction zone as derived from local,
-! regional, and teleseismic events" by Zhao, Hasegawa & Kanamori,
-! JGR, 99, 22313-22329, 1994.
-!
-! The meaningful range of this model is as follows:
-! latitude : 32 - 45 N
-! longitude: 130-145 E
-! depth : 0 - 500 km
-!
-! Dapeng Zhao
-! Dept. of Earth & Planet. Sci
-! Washington University
-! St. Louis, MO 63130
-! U.S.A.
-! dapeng at izu.wustl.edu
-!=========================================================================
-subroutine read_iso3d_dpzhao_model(JP3DM_V)
-
- implicit none
-
- include "constants.h"
-! 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
-
- OPEN(2,FILE="DATA/Zhao_JP_model/m3d1341")
- OPEN(3,FILE="DATA/Zhao_JP_model/datadis")
-
- CALL INPUTJP(JP3DM_V)
- CALL INPUT1(JP3DM_V)
- CALL INPUT2(JP3DM_V)
-
-end subroutine read_iso3d_dpzhao_model
-!==========================================================================
-subroutine iso3d_dpzhao_model(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
- implicit none
-
- include "constants.h"
-
-! 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
-
- logical found_crust
- double precision :: radius,theta,phi,vp,vs,dvs,dvp,rho
- double precision :: PE,RE,HE,H1,H2,H3,scaleval
- integer :: LAY
-
-
- found_crust = .false.
-
- PE = theta
- RE = phi
- HE = (ONE - radius)*R_EARTH_KM
-! calculate depths of the Conrad, the Moho and
-! the plate boundary beneath the location (PHI,RAM)
- CALL HLAY(PE,RE,H1,1,JP3DM_V)
- CALL HLAY(PE,RE,H2,2,JP3DM_V)
- CALL HLAY(PE,RE,H3,3,JP3DM_V)
-! when LAY = 1, the focus is in the upper crust;
-! when LAY = 2, the focus is in the lower crust;
-! when LAY = 3, the focus is in the mantle wedge;
-! when LAY = 4, the focus is beneath the plate boundary.
- IF(HE.LE.H1) THEN
- LAY = 1
- found_crust = .true.
- ELSE IF(HE.GT.H1.AND.HE.LE.H2) THEN
- LAY = 2
- found_crust = .true.
- ELSE IF(HE.GT.H2.AND.HE.LE.H3) THEN
- LAY = 3
- ELSE
- LAY = 4
- END IF
- CALL VEL1D(HE,vp,LAY,1,JP3DM_V)
- CALL VEL1D(HE,vs,LAY,2,JP3DM_V)
-
- CALL VEL3(PE,RE,HE,dvp,LAY,JP3DM_V)
- dvp = 0.01d0*dvp
- dvs = 1.5d0*dvp
- vp = vp*(1.0d0+dvp)
- vs = vs*(1.0d0+dvs)
-
-! determine rho
- if(LAY .eq. 1) then
- rho=2.6
- endif
- if(LAY .eq. 2) then
- rho=2.9
- endif
- if(LAY .GT. 2) then
- rho=3.3+(vs-4.4)*0.66667
- endif
-! non-dimensionalize
-! time scaling (s^{-1}) is done with scaleval
- scaleval=dsqrt(PI*GRAV*RHOAV)
- rho=rho*1000.0d0/RHOAV
- vp=vp*1000.0d0/(R_EARTH*scaleval)
- vs=vs*1000.0d0/(R_EARTH*scaleval)
-END subroutine iso3d_dpzhao_model
-
-!---------------------------------------------------------------
-
- SUBROUTINE INPUT1(JP3DM_V)
- implicit none
-
- include "constants.h"
-! 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
-
-100 FORMAT(3I3)
- READ(2,100) JP3DM_V%NPA,JP3DM_V%NRA,JP3DM_V%NHA
- CALL PUT1(JP3DM_V%NPA,JP3DM_V%NRA,JP3DM_V%NHA,JP3DM_V%PNA,JP3DM_V%RNA,JP3DM_V%HNA,JP3DM_V%VELAP)
- READ(2,100) JP3DM_V%NPB,JP3DM_V%NRB,JP3DM_V%NHB
- CALL PUT1(JP3DM_V%NPB,JP3DM_V%NRB,JP3DM_V%NHB,JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,JP3DM_V%VELBP)
- CALL BLDMAP(JP3DM_V)
- RETURN
- END SUBROUTINE INPUT1
-
- SUBROUTINE PUT1(NPX,NRX,NHX,PNX,RNX,HNX,VELXP)
- integer :: NPX,NRX,NHX,K,I,J
- double precision :: VELXP(NPX,NRX,NHX), &
- PNX(NPX),RNX(NRX),HNX(NHX)
- READ(2,110) (PNX(I),I=1,NPX)
- READ(2,110) (RNX(I),I=1,NRX)
- READ(2,120) (HNX(I),I=1,NHX)
- DO K = 1,NHX
- DO I = 1,NPX
- READ(2,140) (VELXP(I,J,K),J=1,NRX)
-110 FORMAT(6(9F7.2/))
-120 FORMAT(3(8F7.2/))
-140 FORMAT(4(14F5.2/))
- enddo
- enddo
- END SUBROUTINE PUT1
-
- SUBROUTINE INPUT2(JP3DM_V)
- implicit none
-
- include "constants.h"
-
-! 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
-
- integer :: NP,NNR,I,J
- READ(3,100) NP,NNR
- READ(3,110) (JP3DM_V%PN(I),I=1,NP)
- READ(3,120) (JP3DM_V%RRN(I),I=1,NNR)
- DO 1 I = NP,1,-1
- READ(3,130) (JP3DM_V%DEPA(I,J),J=1,NNR)
-1 CONTINUE
- DO 2 I = NP,1,-1
- READ(3,130) (JP3DM_V%DEPB(I,J),J=1,NNR)
-2 CONTINUE
- DO 3 I = NP,1,-1
- READ(3,130) (JP3DM_V%DEPC(I,J),J=1,NNR)
-3 CONTINUE
-100 FORMAT(2I6)
-110 FORMAT(5(10F7.2/),F7.2)
-120 FORMAT(6(10F7.2/),3F7.2)
-130 FORMAT(6(10F7.1/),3F7.1)
- RETURN
- END
-
- SUBROUTINE BLDMAP(JP3DM_V)
- implicit none
-
- include "constants.h"
-! 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
-
- CALL LOCX(JP3DM_V%PNA,JP3DM_V%RNA,JP3DM_V%HNA,JP3DM_V%NPA,JP3DM_V%NRA,JP3DM_V%NHA,MKA, &
- JP3DM_V%PLA,JP3DM_V%RLA,JP3DM_V%HLA,JP3DM_V%IPLOCA,JP3DM_V%IRLOCA,JP3DM_V%IHLOCA)
- CALL LOCX(JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,JP3DM_V%NPB,JP3DM_V%NRB,JP3DM_V%NHB,MKB, &
- JP3DM_V%PLB,JP3DM_V%RLB,JP3DM_V%HLB,JP3DM_V%IPLOCB,JP3DM_V%IRLOCB,JP3DM_V%IHLOCB)
- RETURN
- END
-
- SUBROUTINE LOCX(PNX,RNX,HNX,NPX,NRX,NHX,MKX, &
- PLX,RLX,HLX,IPLOCX,IRLOCX,IHLOCX)
- integer :: NPX,NRX,NHX,MKX,IPLOCX(MKX),IRLOCX(MKX),IHLOCX(MKX)
- integer :: IPMAX,IP,IP1,IRMAX,IR,IR1,IH1,IH,IHMAX,I
- double precision :: PNX(NPX),RNX(NRX),HNX(NHX)
- double precision :: PLX,RLX,HLX,PNOW,RNOW,HNOW
- PLX = 1.0-PNX(1)*100.0
- IPMAX = IDNINT(PNX(NPX)*100.0+PLX)
- IP = 1
- DO 10 I = 1,IPMAX
- IP1 = IP+1
- PNOW = (FLOAT(I)-PLX)/100.0
- IF(PNOW.GE.PNX(IP1)) IP = IP1
- IPLOCX(I)= IP
-10 CONTINUE
- RLX = 1.0-RNX(1)*100.0
- IRMAX = IDNINT(RNX(NRX)*100.0+RLX)
- IR = 1
- DO 20 I = 1,IRMAX
- IR1 = IR+1
- RNOW = (FLOAT(I)-RLX)/100.0
- IF(RNOW.GE.RNX(IR1)) IR = IR1
- IRLOCX(I)= IR
-20 CONTINUE
- HLX = 1.0-HNX(1)
- IHMAX = IDNINT(HNX(NHX)+HLX)
- IH = 1
- DO 30 I = 1,IHMAX
- IH1 = IH+1
- HNOW = FLOAT(I)-HLX
- IF(HNOW.GE.HNX(IH1)) IH = IH1
- IHLOCX(I)= IH
-30 CONTINUE
- RETURN
- END
-
- SUBROUTINE VEL3(PE,RE,HE,V,LAY,JP3DM_V)
- implicit none
-
- include "constants.h"
-! 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
-
- double precision :: PE,RE,HE,V
-
- integer :: LAY
-
- JP3DM_V%P = 90.0-PE/DEGREES_TO_RADIANS
- JP3DM_V%R = RE/DEGREES_TO_RADIANS
- JP3DM_V%H = HE
- IF(LAY.LE.3) THEN
- CALL PRHF(JP3DM_V%IPLOCA,JP3DM_V%IRLOCA,JP3DM_V%IHLOCA,JP3DM_V%PLA,JP3DM_V%RLA,JP3DM_V%HLA, &
- JP3DM_V%PNA,JP3DM_V%RNA,JP3DM_V%HNA,MPA,MRA,MHA,MKA,JP3DM_V)
- ELSE IF(LAY.EQ.4) THEN
- CALL PRHF(JP3DM_V%IPLOCB,JP3DM_V%IRLOCB,JP3DM_V%IHLOCB,JP3DM_V%PLB,JP3DM_V%RLB,JP3DM_V%HLB, &
- JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,MPB,MRB,MHB,MKB,JP3DM_V)
- ELSE
- END IF
- JP3DM_V%WV(1) = JP3DM_V%PF1*JP3DM_V%RF1*JP3DM_V%HF1
- JP3DM_V%WV(2) = JP3DM_V%PF*JP3DM_V%RF1*JP3DM_V%HF1
- JP3DM_V%WV(3) = JP3DM_V%PF1*JP3DM_V%RF*JP3DM_V%HF1
- JP3DM_V%WV(4) = JP3DM_V%PF*JP3DM_V%RF*JP3DM_V%HF1
- JP3DM_V%WV(5) = JP3DM_V%PF1*JP3DM_V%RF1*JP3DM_V%HF
- JP3DM_V%WV(6) = JP3DM_V%PF*JP3DM_V%RF1*JP3DM_V%HF
- JP3DM_V%WV(7) = JP3DM_V%PF1*JP3DM_V%RF*JP3DM_V%HF
- JP3DM_V%WV(8) = JP3DM_V%PF*JP3DM_V%RF*JP3DM_V%HF
- ! calculate velocity
- IF(LAY.LE.3) THEN
- CALL VABPS(MPA,MRA,MHA,JP3DM_V%VELAP,V,JP3DM_V)
- ELSE IF(LAY.EQ.4) THEN
- CALL VABPS(MPB,MRB,MHB,JP3DM_V%VELBP,V,JP3DM_V)
- ELSE
- END IF
-
- RETURN
- END SUBROUTINE VEL3
-
- SUBROUTINE VABPS(MP,MR,MH,V,VEL,JP3DM_V)
- implicit none
-
- include "constants.h"
-
-
-! 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
- double precision :: VEL
- integer :: MP,MR,MH
- double precision :: V(MP,MR,MH)
- VEL = JP3DM_V%WV(1)*V(JP3DM_V%IP,JP3DM_V%JP,JP3DM_V%KP) + JP3DM_V%WV(2)*V(JP3DM_V%IP1,JP3DM_V%JP,JP3DM_V%KP) &
- + JP3DM_V%WV(3)*V(JP3DM_V%IP,JP3DM_V%JP1,JP3DM_V%KP) + JP3DM_V%WV(4)*V(JP3DM_V%IP1,JP3DM_V%JP1,JP3DM_V%KP) &
- + JP3DM_V%WV(5)*V(JP3DM_V%IP,JP3DM_V%JP,JP3DM_V%KP1) + JP3DM_V%WV(6)*V(JP3DM_V%IP1,JP3DM_V%JP,JP3DM_V%KP1) &
- + JP3DM_V%WV(7)*V(JP3DM_V%IP,JP3DM_V%JP1,JP3DM_V%KP1)+ JP3DM_V%WV(8)*V(JP3DM_V%IP1,JP3DM_V%JP1,JP3DM_V%KP1)
- RETURN
- END
-
- SUBROUTINE INTMAP(R,IRLOC,NNR,RL,IR)
- integer :: NNR,IRLOC(NNR),IS,IR
- double precision :: R,RL
- IS = IDNINT(R+RL)
- IR = IRLOC(IS)
- RETURN
- END
-
- SUBROUTINE PRHF(IPLOCX,IRLOCX,IHLOCX,PLX,RLX,HLX, &
- PNX,RNX,HNX,MPX,MRX,MHX,MKX,JP3DM_V)
- implicit none
-
- include "constants.h"
-
-! 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
-
- integer :: MPX,MRX,MHX,MKX
- integer :: IPLOCX(MKX),IRLOCX(MKX),IHLOCX(MKX)
- double precision :: PNX(MPX),RNX(MRX),HNX(MHX)
- double precision :: PLX,RLX,HLX
- CALL LIMIT(PNX(1),PNX(MPX),JP3DM_V%P)
- CALL LIMIT(RNX(1),RNX(MRX),JP3DM_V%R)
- CALL LIMIT(HNX(1),HNX(MHX),JP3DM_V%H)
- CALL INTMAP(JP3DM_V%P*100.0,IPLOCX,MKX,PLX,JP3DM_V%IP)
- CALL INTMAP(JP3DM_V%R*100.0,IRLOCX,MKX,RLX,JP3DM_V%JP)
- CALL INTMAP(JP3DM_V%H,IHLOCX,MKX,HLX,JP3DM_V%KP)
- JP3DM_V%IP1 = JP3DM_V%IP+1
- JP3DM_V%JP1 = JP3DM_V%JP+1
- JP3DM_V%KP1 = JP3DM_V%KP+1
- JP3DM_V%PD = PNX(JP3DM_V%IP1)-PNX(JP3DM_V%IP)
- JP3DM_V%RD = RNX(JP3DM_V%JP1)-RNX(JP3DM_V%JP)
- JP3DM_V%HD = HNX(JP3DM_V%KP1)-HNX(JP3DM_V%KP)
- JP3DM_V%PF = (JP3DM_V%P-PNX(JP3DM_V%IP))/JP3DM_V%PD
- JP3DM_V%RF = (JP3DM_V%R-RNX(JP3DM_V%JP))/JP3DM_V%RD
- JP3DM_V%HF = (JP3DM_V%H-HNX(JP3DM_V%KP))/JP3DM_V%HD
- JP3DM_V%PF1 = 1.0-JP3DM_V%PF
- JP3DM_V%RF1 = 1.0-JP3DM_V%RF
- JP3DM_V%HF1 = 1.0-JP3DM_V%HF
- RETURN
- END
-
- SUBROUTINE HLAY(PE,RE,HE,IJK,JP3DM_V)
- implicit none
-
- include "constants.h"
-! 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
- double precision :: PE,RE,HE,WV1,WV2,WV3,WV4,P,R,PF,RF,PF1,RF1
- integer :: IJK,J,J1,I,I1
- P = 90.0-PE/DEGREES_TO_RADIANS
- R = RE/DEGREES_TO_RADIANS
- CALL LIMIT(JP3DM_V%PN(1),JP3DM_V%PN(51),P)
- CALL LIMIT(JP3DM_V%RRN(1),JP3DM_V%RRN(63),R)
- DO 1 I = 1,50
- I1 = I+1
- IF(P.GE.JP3DM_V%PN(I).AND.P.LT.JP3DM_V%PN(I1)) GO TO 11
-1 CONTINUE
-11 CONTINUE
- DO 2 J = 1,62
- J1 = J+1
- IF(R.GE.JP3DM_V%RRN(J).AND.R.LT.JP3DM_V%RRN(J1)) GO TO 22
-2 CONTINUE
-22 CONTINUE
- PF = (P-JP3DM_V%PN(I))/(JP3DM_V%PN(I1)-JP3DM_V%PN(I))
- RF = (R-JP3DM_V%RRN(J))/(JP3DM_V%RRN(J1)-JP3DM_V%RRN(J))
- PF1 = 1.0-PF
- RF1 = 1.0-RF
- WV1 = PF1*RF1
- WV2 = PF*RF1
- WV3 = PF1*RF
- WV4 = PF*RF
- IF(IJK.EQ.1) THEN
- HE = WV1*JP3DM_V%DEPA(I,J) + WV2*JP3DM_V%DEPA(I1,J) &
- + WV3*JP3DM_V%DEPA(I,J1) + WV4*JP3DM_V%DEPA(I1,J1)
- ELSE IF(IJK.EQ.2) THEN
- HE = WV1*JP3DM_V%DEPB(I,J) + WV2*JP3DM_V%DEPB(I1,J) &
- + WV3*JP3DM_V%DEPB(I,J1) + WV4*JP3DM_V%DEPB(I1,J1)
- ELSE IF(IJK.EQ.3) THEN
- HE = WV1*JP3DM_V%DEPC(I,J) + WV2*JP3DM_V%DEPC(I1,J) &
- + WV3*JP3DM_V%DEPC(I,J1) + WV4*JP3DM_V%DEPC(I1,J1)
- ELSE
- END IF
- RETURN
- END SUBROUTINE HLAY
-
- SUBROUTINE LIMIT(C1,C2,C)
- double precision :: A1,A2,C1,C2,C
- A1 = dmin1(C1,C2)
- A2 = dmax1(C1,C2)
- IF(C.LT.A1) C = A1
- IF(C.GT.A2) C = A2
- END SUBROUTINE LIMIT
-
- SUBROUTINE VEL1D(HE,V,LAY,IPS,JP3DM_V)
- implicit none
-
- include "constants.h"
-! 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
-
- integer :: IPS,LAY
- double precision :: HE,V,VM,HM
- IF(LAY.EQ.1) THEN
- V = 6.0
- IF(IPS.EQ.2) V = 3.5
- ELSE IF(LAY.EQ.2) THEN
- V = 6.7
- IF(IPS.EQ.2) V = 3.8
- ELSE IF(LAY.GE.3) THEN
- HM = 40.0
- IF(HE.LT.HM) THEN
- CALL JPMODEL(IPS,HM,VM,JP3DM_V)
- V = VM-(HM-HE)*0.003
- ELSE
- CALL JPMODEL(IPS,HE,V,JP3DM_V)
- END IF
- ELSE
- END IF
- RETURN
- END
-
- SUBROUTINE INPUTJP(JP3DM_V)
- implicit none
-
- include "constants.h"
-! 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
- double precision :: VP1(29),VS1(29),RA1(29)
- integer :: L
- DATA VP1/7.75, 7.94, 8.13, 8.33, 8.54, 8.75, 8.97, &
- 9.50, 9.91,10.26,10.55,10.99,11.29,11.50, &
- 11.67,11.85,12.03,12.20,12.37,12.54,12.71, &
- 12.87,13.02,13.16,13.32,13.46,13.60,13.64,13.64/
- DATA VS1/4.353,4.444,4.539,4.638,4.741,4.850,4.962, &
- 5.227,5.463,5.670,5.850,6.125,6.295,6.395, &
- 6.483,6.564,6.637,6.706,6.770,6.833,6.893, &
- 6.953,7.012,7.074,7.137,7.199,7.258,7.314,7.304/
- DATA RA1/1.00,0.99,0.98,0.97,0.96,0.95,0.94,0.93, &
- 0.92,0.91,0.90,0.88,0.86,0.84,0.82,0.80, &
- 0.78,0.76,0.74,0.72,0.70,0.68,0.66,0.64, &
- 0.62,0.60,0.58,0.56,0.55/
- DO 1 L = 1,29
- JP3DM_V%VP(L) = VP1(L)
- JP3DM_V%VS(L) = VS1(L)
- JP3DM_V%RA(L) = RA1(L)
- JP3DM_V%DEPJ(L) = 40.0+6325.59*(1.0-RA1(L))
-1 CONTINUE
- RETURN
- END
-
- SUBROUTINE JPMODEL(IPS,H,V,JP3DM_V)
- implicit none
-
- include "constants.h"
-! 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
- integer :: IPS,K,K1
- double precision :: H1,H2,H12,H,V
- DO 2 K = 1,28
- K1 = K+1
- H1 = JP3DM_V%DEPJ(K)
- H2 = JP3DM_V%DEPJ(K1)
- IF(H.GE.H1.AND.H.LT.H2) GO TO 3
-2 CONTINUE
-3 CONTINUE
- H12 = (H-H1)/(H2-H1)
- IF(IPS.EQ.1) THEN
- V = (JP3DM_V%VP(K1)-JP3DM_V%VP(K))*H12+JP3DM_V%VP(K)
- ELSE
- V = (JP3DM_V%VS(K1)-JP3DM_V%VS(K))*H12+JP3DM_V%VS(K)
- END IF
- RETURN
- END
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lagrange_poly.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lagrange_poly.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lagrange_poly.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,110 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 lagrange_any(xi,NGLL,xigll,h,hprime)
-
-! subroutine to compute the Lagrange interpolants based upon the GLL points
-! and their first derivatives at any point xi in [-1,1]
-
- implicit none
-
- integer NGLL
- double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)
-
- integer dgr,i,j
- double precision prod1,prod2
-
- do dgr=1,NGLL
-
- prod1 = 1.0d0
- prod2 = 1.0d0
- do i=1,NGLL
- if(i /= dgr) then
- prod1 = prod1*(xi-xigll(i))
- prod2 = prod2*(xigll(dgr)-xigll(i))
- endif
- enddo
- h(dgr)=prod1/prod2
-
- hprime(dgr)=0.0d0
- do i=1,NGLL
- if(i /= dgr) then
- prod1=1.0d0
- do j=1,NGLL
- if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
- enddo
- hprime(dgr) = hprime(dgr)+prod1
- endif
- enddo
- hprime(dgr) = hprime(dgr)/prod2
-
- enddo
-
- end subroutine lagrange_any
-
-!
-!=====================================================================
-!
-
-! subroutine to compute the derivative of the Lagrange interpolants
-! at the GLL points at any given GLL point
-
- double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)
-
-!------------------------------------------------------------------------
-!
-! Compute the value of the derivative of the I-th
-! Lagrange interpolant through the
-! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
-!
-!------------------------------------------------------------------------
-
- implicit none
-
- integer i,j,nz
- double precision zgll(0:nz-1)
-
- integer degpoly
-
- double precision, external :: pnleg,pndleg
-
- degpoly = nz - 1
- if (i == 0 .and. j == 0) then
- lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
- else if (i == degpoly .and. j == degpoly) then
- lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
- else if (i == j) then
- lagrange_deriv_GLL = 0.d0
- else
- lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
- (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
- + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
- (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
- endif
-
- end function lagrange_deriv_GLL
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lgndr.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lgndr.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lgndr.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,152 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 lgndr(l,c,s,x,dx)
-
-! computes Legendre function x(l,m,theta)
-! theta=colatitude,c=cos(theta),s=sin(theta),l=angular order,
-! sin(theta) restricted so that sin(theta) > 1.e-7
-! x(1) contains m=0, x(2) contains m=1, x(k+1) contains m=k
-! m=azimuthal (longitudinal) order 0 <= m <= l
-! dx=dx/dtheta
-!
-! subroutine originally came from Physics Dept. Princeton through
-! Peter Davis, modified by Jeffrey Park
-
- implicit none
-
-! argument variables
- integer l
- double precision x(2*l+1),dx(2*l+1)
- double precision c,s
-
-! local variables
- integer i,lp1,lpsafe,lsave
- integer m,maxsin,mmm,mp1
-
- double precision sqroot2over2,c1,c2,cot
- double precision ct,d,f1,f2
- double precision f3,fac,g1,g2
- double precision g3,rfpi,sqroot3,sos
- double precision ss,stom,t,tol
- double precision v,y
-
- tol = 1.d-05
- rfpi = 0.282094791773880d0
- sqroot3 = 1.73205080756890d0
- sqroot2over2 = 0.707106781186550d0
-
- if(s >= 1.0d0-tol) s=1.0d0-tol
- lsave=l
- if(l<0) l=-1-l
- if(l>0) goto 1
- x(1)=rfpi
- dx(1)=0.0d0
- l=lsave
- return
- 1 if(l /= 1) goto 2
- c1=sqroot3*rfpi
- c2=sqroot2over2*c1
- x(1)=c1*c
- x(2)=-c2*s
- dx(1)=-c1*s
- dx(2)=-c2*c
- l=lsave
- return
- 2 sos=s
- if(s<tol) s=tol
- cot=c/s
- ct=2.0d0*c
- ss=s*s
- lp1=l+1
- g3=0.0d0
- g2=1.0d0
- f3=0.0d0
-
-! evaluate m=l value, sans (sin(theta))**l
- do i=1,l
- g2=g2*(1.0d0-1.0d0/(2.0d0*i))
- enddo
- g2=rfpi*dsqrt((2*l+1)*g2)
- f2=l*cot*g2
- x(lp1)=g2
- dx(lp1)=f2
- v=1.0d0
- y=2.0d0*l
- d=dsqrt(v*y)
- t=0.0d0
- mp1=l
- m=l-1
-
-! these recursions are similar to ordinary m-recursions, but since we
-! have taken the s**m factor out of the xlm's, the recursion has the powers
-! of sin(theta) instead
- 3 g1=-(ct*mp1*g2+ss*t*g3)/d
- f1=(mp1*(2.0d0*s*g2-ct*f2)-t*ss*(f3+cot*g3))/d-cot*g1
- x(mp1)=g1
- dx(mp1)=f1
- if(m == 0) goto 4
- mp1=m
- m=m-1
- v=v+1.0d0
- y=y-1.0d0
- t=d
- d=dsqrt(v*y)
- g3=g2
- g2=g1
- f3=f2
- f2=f1
- goto 3
-! explicit conversion to integer added
- 4 maxsin=int(-72.0d0/log10(s))
-
-! maxsin is the max exponent of sin(theta) without underflow
- lpsafe=min0(lp1,maxsin)
- stom=1.0d0
- fac=sign(1.0d0,dble((l/2)*2-l) + 0.50d0)
-
-! multiply xlm by sin**m
- do m=1,lpsafe
- x(m)=fac*x(m)*stom
- dx(m)=fac*dx(m)*stom
- stom=stom*s
- enddo
-
-! set any remaining xlm to zero
- if(maxsin <= l) then
- mmm=maxsin+1
- do m=mmm,lp1
- x(m)=0.0d0
- dx(m)=0.0d0
- enddo
- endif
-
- s=sos
- l=lsave
-
- end subroutine lgndr
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_receivers.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_receivers.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -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 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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, allocatable, dimension(:) :: ix_initial_guess,iy_initial_guess,iz_initial_guess
-
- integer iorientation
- integer iprocloop
- double precision stazi,stdip
-
- double precision, allocatable, dimension(:) :: x_target,y_target,z_target
- double precision, allocatable, dimension(:) :: epidist
- double precision, allocatable, dimension(:) :: x_found,y_found,z_found
- double precision, allocatable, dimension(:,:) :: x_found_all,y_found_all,z_found_all
-
- 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
-
-! use dynamic allocation
- double precision, dimension(:), allocatable :: final_distance
- double precision, dimension(:,:), allocatable :: final_distance_all
- 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
-
- integer, allocatable, dimension(:,:) :: ispec_selected_rec_all
- double precision, dimension(nrec) :: stlat,stlon,stele
- double precision, allocatable, dimension(:) :: stbur
- double precision, allocatable, dimension(:,:) :: 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
-
-! allocate memory for arrays using number of stations
- allocate(stbur(nrec))
- allocate(epidist(nrec))
-
- allocate(ix_initial_guess(nrec))
- allocate(iy_initial_guess(nrec))
- allocate(iz_initial_guess(nrec))
- allocate(x_target(nrec))
- allocate(y_target(nrec))
- allocate(z_target(nrec))
- allocate(x_found(nrec))
- allocate(y_found(nrec))
- allocate(z_found(nrec))
- allocate(final_distance(nrec))
-
- allocate(ispec_selected_rec_all(nrec,0:NPROCTOT-1))
- allocate(xi_receiver_all(nrec,0:NPROCTOT-1))
- allocate(eta_receiver_all(nrec,0:NPROCTOT-1))
- allocate(gamma_receiver_all(nrec,0:NPROCTOT-1))
- allocate(x_found_all(nrec,0:NPROCTOT-1))
- allocate(y_found_all(nrec,0:NPROCTOT-1))
- allocate(z_found_all(nrec,0:NPROCTOT-1))
- allocate(final_distance_all(nrec,0:NPROCTOT-1))
-
-! 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')
- 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')
- 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_BARRIER(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)
-
-! deallocate arrays
- deallocate(stbur)
- deallocate(epidist)
- deallocate(ix_initial_guess)
- deallocate(iy_initial_guess)
- deallocate(iz_initial_guess)
- deallocate(x_target)
- deallocate(y_target)
- deallocate(z_target)
- deallocate(x_found)
- deallocate(y_found)
- deallocate(z_found)
- deallocate(final_distance)
- deallocate(ispec_selected_rec_all)
- deallocate(xi_receiver_all)
- deallocate(eta_receiver_all)
- deallocate(gamma_receiver_all)
- deallocate(x_found_all)
- deallocate(y_found_all)
- deallocate(z_found_all)
- deallocate(final_distance_all)
-
- end subroutine locate_receivers
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_sources.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_sources.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,706 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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, dimension(:), allocatable :: final_distance_source_subset
-
- 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)
- integer, dimension(:), allocatable :: ispec_selected_source_subset
-
- integer, dimension(:,:), allocatable :: ispec_selected_source_all
- double precision, dimension(:,:), allocatable :: 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 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(:), allocatable :: xi_source_subset,eta_source_subset,gamma_source_subset
-
- 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, dimension(:), allocatable :: x_found_source,y_found_source,z_found_source
- 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)
-
-! **************
-
-! 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)
-
-! allocate arrays specific to each subset
- allocate(final_distance_source_subset(NSOURCES_SUBSET_current_size))
-
- allocate(ispec_selected_source_subset(NSOURCES_SUBSET_current_size))
-
- allocate(ispec_selected_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
-
- allocate(xi_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
- allocate(eta_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
- allocate(gamma_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
-
- allocate(final_distance_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
-
- allocate(x_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
- allocate(y_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
- allocate(z_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
-
- allocate(xi_source_subset(NSOURCES_SUBSET_current_size))
- allocate(eta_source_subset(NSOURCES_SUBSET_current_size))
- allocate(gamma_source_subset(NSOURCES_SUBSET_current_size))
-
- allocate(x_found_source(NSOURCES_SUBSET_current_size))
- allocate(y_found_source(NSOURCES_SUBSET_current_size))
- allocate(z_found_source(NSOURCES_SUBSET_current_size))
-
-! 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(:,:) = -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(isource_in_this_subset,iprocloop) < distmin) then
- distmin = final_distance_source_all(isource_in_this_subset,iprocloop)
- islice_selected_source(isource) = iprocloop
- ispec_selected_source(isource) = ispec_selected_source_all(isource_in_this_subset,iprocloop)
- xi_source(isource) = xi_source_all(isource_in_this_subset,iprocloop)
- eta_source(isource) = eta_source_all(isource_in_this_subset,iprocloop)
- gamma_source(isource) = gamma_source_all(isource_in_this_subset,iprocloop)
- x_found_source(isource_in_this_subset) = x_found_source_all(isource_in_this_subset,iprocloop)
- y_found_source(isource_in_this_subset) = y_found_source_all(isource_in_this_subset,iprocloop)
- z_found_source(isource_in_this_subset) = z_found_source_all(isource_in_this_subset,iprocloop)
- 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'
-
-! 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')
-
- scalar_moment = 0.
- do i = 1,6
- scalar_moment = scalar_moment + moment_tensor(i,isource)**2
- enddo
- scalar_moment = dsqrt(scalar_moment/2.)
-
- 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')
-
- 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
-
-! deallocate arrays specific to each subset
- deallocate(final_distance_source_subset)
- deallocate(ispec_selected_source_subset)
- deallocate(ispec_selected_source_all)
- deallocate(xi_source_all,eta_source_all,gamma_source_all,final_distance_source_all)
- deallocate(x_found_source_all,y_found_source_all,z_found_source_all)
- deallocate(xi_source_subset,eta_source_subset,gamma_source_subset)
- deallocate(x_found_source,y_found_source,z_found_source)
-
- enddo ! end of loop over all source subsets
-
-! 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_ellipticity.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_ellipticity.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_ellipticity.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,175 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
-
-! creates a spline for the ellipticity profile in PREM
-! radius and density are non-dimensional
-
- implicit none
-
- include "constants.h"
-
- integer nspl
-
- logical ONE_CRUST
-
-! radius of the Earth for gravity calculation
- double precision, parameter :: R_EARTH_ELLIPTICITY = 6371000.d0
-! radius of the ocean floor for gravity calculation
- double precision, parameter :: ROCEAN_ELLIPTICITY = 6368000.d0
-
- double precision rspl(NR),espl(NR),espl2(NR)
-
- integer i
- double precision ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670, &
- R771,RTOPDDOUBLEPRIME,RCMB,RICB
- double precision r_icb,r_cmb,r_topddoubleprime,r_771,r_670,r_600
- double precision r_400,r_220,r_80,r_moho,r_middle_crust,r_ocean,r_0
- double precision r(NR),rho(NR),epsilonval(NR),eta(NR)
- double precision radau(NR),z,k(NR),g_a,bom,exponentval,i_rho,i_radau
- double precision s1(NR),s2(NR),s3(NR)
- double precision yp1,ypn
-
-! 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
-
-! non-dimensionalize
- r_icb = RICB/R_EARTH_ELLIPTICITY
- r_cmb = RCMB/R_EARTH_ELLIPTICITY
- r_topddoubleprime = RTOPDDOUBLEPRIME/R_EARTH_ELLIPTICITY
- r_771 = R771/R_EARTH_ELLIPTICITY
- r_670 = R670/R_EARTH_ELLIPTICITY
- r_600 = R600/R_EARTH_ELLIPTICITY
- r_400 = R400/R_EARTH_ELLIPTICITY
- r_220 = R220/R_EARTH_ELLIPTICITY
- r_80 = R80/R_EARTH_ELLIPTICITY
- r_moho = RMOHO/R_EARTH_ELLIPTICITY
- r_middle_crust = RMIDDLE_CRUST/R_EARTH_ELLIPTICITY
- r_ocean = ROCEAN_ELLIPTICITY/R_EARTH_ELLIPTICITY
- r_0 = 1.d0
-
- do i=1,163
- r(i) = r_icb*dble(i-1)/dble(162)
- enddo
- do i=164,323
- r(i) = r_icb+(r_cmb-r_icb)*dble(i-164)/dble(159)
- enddo
- do i=324,336
- r(i) = r_cmb+(r_topddoubleprime-r_cmb)*dble(i-324)/dble(12)
- enddo
- do i=337,517
- r(i) = r_topddoubleprime+(r_771-r_topddoubleprime)*dble(i-337)/dble(180)
- enddo
- do i=518,530
- r(i) = r_771+(r_670-r_771)*dble(i-518)/dble(12)
- enddo
- do i=531,540
- r(i) = r_670+(r_600-r_670)*dble(i-531)/dble(9)
- enddo
- do i=541,565
- r(i) = r_600+(r_400-r_600)*dble(i-541)/dble(24)
- enddo
- do i=566,590
- r(i) = r_400+(r_220-r_400)*dble(i-566)/dble(24)
- enddo
- do i=591,609
- r(i) = r_220+(r_80-r_220)*dble(i-591)/dble(18)
- enddo
- do i=610,619
- r(i) = r_80+(r_moho-r_80)*dble(i-610)/dble(9)
- enddo
- do i=620,626
- r(i) = r_moho+(r_middle_crust-r_moho)*dble(i-620)/dble(6)
- enddo
- do i=627,633
- r(i) = r_middle_crust+(r_ocean-r_middle_crust)*dble(i-627)/dble(6)
- enddo
- do i=634,NR
- r(i) = r_ocean+(r_0-r_ocean)*dble(i-634)/dble(6)
- enddo
-
-
-! use PREM to get the density profile for ellipticity (fine for other 1D reference models)
- do i=1,NR
- call prem_density(r(i),rho(i),ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
- radau(i)=rho(i)*r(i)*r(i)
- enddo
-
- eta(1)=0.0d0
-
- k(1)=0.0d0
-
- do i=2,NR
- call intgrl(i_rho,r,1,i,rho,s1,s2,s3)
- call intgrl(i_radau,r,1,i,radau,s1,s2,s3)
- z=(2.0d0/3.0d0)*i_radau/(i_rho*r(i)*r(i))
- eta(i)=(25.0d0/4.0d0)*((1.0d0-(3.0d0/2.0d0)*z)**2.0d0)-1.0d0
- k(i)=eta(i)/(r(i)**3.0d0)
- enddo
-
- g_a=4.0D0*i_rho
- bom=TWO_PI/(24.0d0*3600.0d0)
- bom=bom/sqrt(PI*GRAV*RHOAV)
- epsilonval(NR)=15.0d0*(bom**2.0d0)/(24.0d0*i_rho*(eta(NR)+2.0d0))
-
- do i=1,NR-1
- call intgrl(exponentval,r,i,NR,k,s1,s2,s3)
- epsilonval(i)=epsilonval(NR)*exp(-exponentval)
- enddo
-
-! get ready to spline epsilonval
- nspl=1
- rspl(1)=r(1)
- espl(1)=epsilonval(1)
- do i=2,NR
- if(r(i) /= r(i-1)) then
- nspl=nspl+1
- rspl(nspl)=r(i)
- espl(nspl)=epsilonval(i)
- endif
- enddo
-
-! spline epsilonval
- yp1=0.0d0
- ypn=(5.0d0/2.0d0)*(bom**2)/g_a-2.0d0*epsilonval(NR)
- call spline_construction(rspl,espl,nspl,yp1,ypn,espl2)
-
- end subroutine make_ellipticity
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_gravity.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_gravity.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_gravity.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,156 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 make_gravity(nspl,rspl,gspl,gspl2,ONE_CRUST)
-
-! creates a spline for the gravity profile in PREM
-! radius and density are non-dimensional
-
- implicit none
-
- include "constants.h"
-
- integer nspl
-
- logical ONE_CRUST
-
-! radius of the Earth for gravity calculation
- double precision, parameter :: R_EARTH_GRAVITY = 6371000.d0
-! radius of the ocean floor for gravity calculation
- double precision, parameter :: ROCEAN_GRAVITY = 6368000.d0
-
- double precision rspl(NR),gspl(NR),gspl2(NR)
-
- integer i
- double precision ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670, &
- R771,RTOPDDOUBLEPRIME,RCMB,RICB
- double precision r_icb,r_cmb,r_topddoubleprime,r_771,r_670,r_600
- double precision r_400,r_220,r_80,r_moho,r_middle_crust,r_ocean,r_0
- double precision r(NR),rho(NR),g(NR),i_rho
- double precision s1(NR),s2(NR),s3(NR)
- double precision yp1,ypn
-
-! 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
-
-! non-dimensionalize
- r_icb = RICB/R_EARTH_GRAVITY
- r_cmb = RCMB/R_EARTH_GRAVITY
- r_topddoubleprime = RTOPDDOUBLEPRIME/R_EARTH_GRAVITY
- r_771 = R771/R_EARTH_GRAVITY
- r_670 = R670/R_EARTH_GRAVITY
- r_600 = R600/R_EARTH_GRAVITY
- r_400 = R400/R_EARTH_GRAVITY
- r_220 = R220/R_EARTH_GRAVITY
- r_80 = R80/R_EARTH_GRAVITY
- r_moho = RMOHO/R_EARTH_GRAVITY
- r_middle_crust = RMIDDLE_CRUST/R_EARTH_GRAVITY
- r_ocean = ROCEAN_GRAVITY/R_EARTH_GRAVITY
- r_0 = 1.d0
-
- do i=1,163
- r(i) = r_icb*dble(i-1)/dble(162)
- enddo
- do i=164,323
- r(i) = r_icb+(r_cmb-r_icb)*dble(i-164)/dble(159)
- enddo
- do i=324,336
- r(i) = r_cmb+(r_topddoubleprime-r_cmb)*dble(i-324)/dble(12)
- enddo
- do i=337,517
- r(i) = r_topddoubleprime+(r_771-r_topddoubleprime)*dble(i-337)/dble(180)
- enddo
- do i=518,530
- r(i) = r_771+(r_670-r_771)*dble(i-518)/dble(12)
- enddo
- do i=531,540
- r(i) = r_670+(r_600-r_670)*dble(i-531)/dble(9)
- enddo
- do i=541,565
- r(i) = r_600+(r_400-r_600)*dble(i-541)/dble(24)
- enddo
- do i=566,590
- r(i) = r_400+(r_220-r_400)*dble(i-566)/dble(24)
- enddo
- do i=591,609
- r(i) = r_220+(r_80-r_220)*dble(i-591)/dble(18)
- enddo
- do i=610,619
- r(i) = r_80+(r_moho-r_80)*dble(i-610)/dble(9)
- enddo
- do i=620,626
- r(i) = r_moho+(r_middle_crust-r_moho)*dble(i-620)/dble(6)
- enddo
- do i=627,633
- r(i) = r_middle_crust+(r_ocean-r_middle_crust)*dble(i-627)/dble(6)
- enddo
- do i=634,NR
- r(i) = r_ocean+(r_0-r_ocean)*dble(i-634)/dble(6)
- enddo
-
-! use PREM to get the density profile for ellipticity (fine for other 1D reference models)
- do i=1,NR
- call prem_density(r(i),rho(i),ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN_GRAVITY)
- enddo
-
- g(1)=0.0d0
- do i=2,NR
- call intgrl(i_rho,r,1,i,rho,s1,s2,s3)
- g(i)=4.0d0*i_rho/(r(i)*r(i))
- enddo
-
-!
-! get ready to spline g
-!
- nspl=1
- rspl(1)=r(1)
- gspl(1)=g(1)
- do i=2,NR
- if(r(i)/=r(i-1)) then
- nspl=nspl+1
- rspl(nspl)=r(i)
- gspl(nspl)=g(i)
- endif
- enddo
- yp1=(4.0d0/3.0d0)*rho(1)
- ypn=4.0d0*rho(NR)-2.0d0*g(NR)/r(NR)
- call spline_construction(rspl,gspl,nspl,yp1,ypn,gspl2)
-
- end subroutine make_gravity
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mantle_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mantle_model.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mantle_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,457 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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_mantle_model(D3MM_V)
-
- implicit none
-
- include "constants.h"
-
-! 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
-
- integer k,l,m
-
- character(len=150) S20RTS, P12
-
- call get_value_string(S20RTS, 'model.S20RTS', 'DATA/s20rts/S20RTS.dat')
- call get_value_string(P12, 'model.P12', 'DATA/s20rts/P12.dat')
-
-! S20RTS degree 20 S model from Ritsema
- open(unit=10,file=S20RTS,status='old',action='read')
- do k=0,NK
- do l=0,NS
- read(10,*) D3MM_V%dvs_a(k,l,0),(D3MM_V%dvs_a(k,l,m),D3MM_V%dvs_b(k,l,m),m=1,l)
- enddo
- enddo
- close(10)
-
-! P12 degree 12 P model from Ritsema
- open(unit=10,file=P12,status='old',action='read')
- do k=0,NK
- do l=0,12
- read(10,*) D3MM_V%dvp_a(k,l,0),(D3MM_V%dvp_a(k,l,m),D3MM_V%dvp_b(k,l,m),m=1,l)
- enddo
- do l=13,NS
- D3MM_V%dvp_a(k,l,0) = 0.0d0
- do m=1,l
- D3MM_V%dvp_a(k,l,m) = 0.0d0
- D3MM_V%dvp_b(k,l,m) = 0.0d0
- enddo
- enddo
- enddo
- close(10)
-
-! set up the splines used as radial basis functions by Ritsema
- call splhsetup(D3MM_V)
-
- end subroutine read_mantle_model
-
-!---------------------------
-
- subroutine mantle_model(radius,theta,phi,dvs,dvp,drho,D3MM_V)
-
- implicit none
-
- include "constants.h"
-
-! 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
-
-! factor to convert perturbations in shear speed to perturbations in density
- double precision, parameter :: SCALE_RHO = 0.40d0
-
- double precision radius,theta,phi,dvs,dvp,drho
-
- double precision, parameter :: RMOHO_ = 6346600.d0
- double precision, parameter :: RCMB_ = 3480000.d0
- double precision, parameter :: R_EARTH_ = 6371000.d0
- double precision, parameter :: ZERO_ = 0.d0
-
- integer l,m,k
- double precision r_moho,r_cmb,xr
- double precision dvs_alm,dvs_blm
- double precision dvp_alm,dvp_blm
- double precision rsple,radial_basis(0:NK)
- double precision sint,cost,x(2*NS+1),dx(2*NS+1)
-
- dvs = ZERO_
- dvp = ZERO_
- drho = ZERO_
-
- r_moho = RMOHO_ / R_EARTH_
- r_cmb = RCMB_ / R_EARTH_
- if(radius>=r_moho .or. radius <= r_cmb) return
-
- xr=-1.0d0+2.0d0*(radius-r_cmb)/(r_moho-r_cmb)
- do k=0,NK
- radial_basis(k)=rsple(1,NK+1,D3MM_V%spknt(1),D3MM_V%qq0(1,NK+1-k),D3MM_V%qq(1,1,NK+1-k),xr)
- enddo
-
- do l=0,NS
- sint=dsin(theta)
- cost=dcos(theta)
- call lgndr(l,cost,sint,x,dx)
- dvs_alm=0.0d0
- dvp_alm=0.0d0
- do k=0,NK
- dvs_alm=dvs_alm+radial_basis(k)*D3MM_V%dvs_a(k,l,0)
- dvp_alm=dvp_alm+radial_basis(k)*D3MM_V%dvp_a(k,l,0)
- enddo
- dvs=dvs+dvs_alm*x(1)
- dvp=dvp+dvp_alm*x(1)
- do m=1,l
- dvs_alm=0.0d0
- dvp_alm=0.0d0
- dvs_blm=0.0d0
- dvp_blm=0.0d0
- do k=0,NK
- dvs_alm=dvs_alm+radial_basis(k)*D3MM_V%dvs_a(k,l,m)
- dvp_alm=dvp_alm+radial_basis(k)*D3MM_V%dvp_a(k,l,m)
- dvs_blm=dvs_blm+radial_basis(k)*D3MM_V%dvs_b(k,l,m)
- dvp_blm=dvp_blm+radial_basis(k)*D3MM_V%dvp_b(k,l,m)
- enddo
- dvs=dvs+(dvs_alm*dcos(dble(m)*phi)+dvs_blm*dsin(dble(m)*phi))*x(m+1)
- dvp=dvp+(dvp_alm*dcos(dble(m)*phi)+dvp_blm*dsin(dble(m)*phi))*x(m+1)
- enddo
- enddo
-
- drho = SCALE_RHO*dvs
-
- end subroutine mantle_model
-
-!----------------------------------
-
- subroutine splhsetup(D3MM_V)!!!!!!!!!!!!!!(spknt,qq0,qq)
-
- implicit none
- include "constants.h"
-
-!!!!!!!!!!!!!!!!!!! double precision spknt(NK+1),qq0(NK+1,NK+1),qq(3,NK+1,NK+1)
-
-! 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
-
-
- integer i,j
- double precision qqwk(3,NK+1)
-
- D3MM_V%spknt(1) = -1.00000d0
- D3MM_V%spknt(2) = -0.78631d0
- D3MM_V%spknt(3) = -0.59207d0
- D3MM_V%spknt(4) = -0.41550d0
- D3MM_V%spknt(5) = -0.25499d0
- D3MM_V%spknt(6) = -0.10909d0
- D3MM_V%spknt(7) = 0.02353d0
- D3MM_V%spknt(8) = 0.14409d0
- D3MM_V%spknt(9) = 0.25367d0
- D3MM_V%spknt(10) = 0.35329d0
- D3MM_V%spknt(11) = 0.44384d0
- D3MM_V%spknt(12) = 0.52615d0
- D3MM_V%spknt(13) = 0.60097d0
- D3MM_V%spknt(14) = 0.66899d0
- D3MM_V%spknt(15) = 0.73081d0
- D3MM_V%spknt(16) = 0.78701d0
- D3MM_V%spknt(17) = 0.83810d0
- D3MM_V%spknt(18) = 0.88454d0
- D3MM_V%spknt(19) = 0.92675d0
- D3MM_V%spknt(20) = 0.96512d0
- D3MM_V%spknt(21) = 1.00000d0
-
- do i=1,NK+1
- do j=1,NK+1
- if(i == j) then
- D3MM_V%qq0(j,i)=1.0d0
- else
- D3MM_V%qq0(j,i)=0.0d0
- endif
- enddo
- enddo
- do i=1,NK+1
- call rspln(1,NK+1,D3MM_V%spknt(1),D3MM_V%qq0(1,i),D3MM_V%qq(1,1,i),qqwk(1,1))
- enddo
-
- end subroutine splhsetup
-
-!----------------------------------
-
-! changed the obsolecent f77 features in the two routines below
-! now still awful Fortran, but at least conforms to f90 standard
-
- double precision function rsple(I1,I2,X,Y,Q,S)
-
- implicit none
-
-! rsple returns the value of the function y(x) evaluated at point S
-! using the cubic spline coefficients computed by rspln and saved in Q.
-! If S is outside the interval (x(i1),x(i2)) rsple extrapolates
-! using the first or last interpolation polynomial. The arrays must
-! be dimensioned at least - x(i2), y(i2), and q(3,i2).
-
- integer i1,i2
- double precision X(*),Y(*),Q(3,*),s
-
- integer i,ii
- double precision h
-
- i = 1
- II=I2-1
-
-! GUARANTEE I WITHIN BOUNDS.
- I=MAX0(I,I1)
- I=MIN0(I,II)
-
-! SEE IF X IS INCREASING OR DECREASING.
- IF(X(I2)-X(I1) < 0) goto 1
- IF(X(I2)-X(I1) >= 0) goto 2
-
-! X IS DECREASING. CHANGE I AS NECESSARY.
- 1 IF(S-X(I) <= 0) goto 3
- IF(S-X(I) > 0) goto 4
-
- 4 I=I-1
-
- IF(I-I1 < 0) goto 11
- IF(I-I1 == 0) goto 6
- IF(I-I1 > 0) goto 1
-
- 3 IF(S-X(I+1) < 0) goto 5
- IF(S-X(I+1) >= 0) goto 6
-
- 5 I=I+1
-
- IF(I-II < 0) goto 3
- IF(I-II == 0) goto 6
- IF(I-II > 0) goto 7
-
-! X IS INCREASING. CHANGE I AS NECESSARY.
- 2 IF(S-X(I+1) <= 0) goto 8
- IF(S-X(I+1) > 0) goto 9
-
- 9 I=I+1
-
- IF(I-II < 0) goto 2
- IF(I-II == 0) goto 6
- IF(I-II > 0) goto 7
-
- 8 IF(S-X(I) < 0) goto 10
- IF(S-X(I) >= 0) goto 6
-
- 10 I=I-1
- IF(I-I1 < 0) goto 11
- IF(I-I1 == 0) goto 6
- IF(I-I1 > 0) goto 8
-
- 7 I=II
- GOTO 6
- 11 I=I1
-
-! CALCULATE RSPLE USING SPLINE COEFFICIENTS IN Y AND Q.
- 6 H=S-X(I)
- RSPLE=Y(I)+H*(Q(1,I)+H*(Q(2,I)+H*Q(3,I)))
-
- end function rsple
-
-!----------------------------------
-
- subroutine rspln(I1,I2,X,Y,Q,F)
-
- implicit none
-
-! Subroutine rspln computes cubic spline interpolation coefficients
-! for y(x) between grid points i1 and i2 saving them in q.The
-! interpolation is continuous with continuous first and second
-! derivatives. It agrees exactly with y at grid points and with the
-! three point first derivatives at both end points (i1 and i2).
-! X must be monotonic but if two successive values of x are equal
-! a discontinuity is assumed and separate interpolation is done on
-! each strictly monotonic segment. The arrays must be dimensioned at
-! least - x(i2), y(i2), q(3,i2), and f(3,i2).
-! F is working storage for rspln.
-
- integer i1,i2
- double precision X(*),Y(*),Q(3,*),F(3,*)
-
- integer i,j,k,j1,j2
- double precision y0,a0,b0,b1,h,h2,ha,h2a,h3a,h2b
- double precision YY(3),small
- equivalence (YY(1),Y0)
- data SMALL/1.0d-08/,YY/0.0d0,0.0d0,0.0d0/
-
- J1=I1+1
- Y0=0.0d0
-
-! BAIL OUT IF THERE ARE LESS THAN TWO POINTS TOTAL
- IF(I2-I1 < 0) return
- IF(I2-I1 == 0) goto 17
- IF(I2-I1 > 0) goto 8
-
- 8 A0=X(J1-1)
-! SEARCH FOR DISCONTINUITIES.
- DO 3 I=J1,I2
- B0=A0
- A0=X(I)
- IF(DABS((A0-B0)/DMAX1(A0,B0)) < SMALL) GOTO 4
- 3 CONTINUE
- 17 J1=J1-1
- J2=I2-2
- GOTO 5
- 4 J1=J1-1
- J2=I-3
-! SEE IF THERE ARE ENOUGH POINTS TO INTERPOLATE (AT LEAST THREE).
- 5 IF(J2+1-J1 < 0) goto 9
- IF(J2+1-J1 == 0) goto 10
- IF(J2+1-J1 > 0) goto 11
-
-! ONLY TWO POINTS. USE LINEAR INTERPOLATION.
- 10 J2=J2+2
- Y0=(Y(J2)-Y(J1))/(X(J2)-X(J1))
- DO J=1,3
- Q(J,J1)=YY(J)
- Q(J,J2)=YY(J)
- enddo
- GOTO 12
-
-! MORE THAN TWO POINTS. DO SPLINE INTERPOLATION.
- 11 A0=0.
- H=X(J1+1)-X(J1)
- H2=X(J1+2)-X(J1)
- Y0=H*H2*(H2-H)
- H=H*H
- H2=H2*H2
-! CALCULATE DERIVITIVE AT NEAR END.
- B0=(Y(J1)*(H-H2)+Y(J1+1)*H2-Y(J1+2)*H)/Y0
- B1=B0
-
-! EXPLICITLY REDUCE BANDED MATRIX TO AN UPPER BANDED MATRIX.
- DO I=J1,J2
- H=X(I+1)-X(I)
- Y0=Y(I+1)-Y(I)
- H2=H*H
- HA=H-A0
- H2A=H-2.0d0*A0
- H3A=2.0d0*H-3.0d0*A0
- H2B=H2*B0
- Q(1,I)=H2/HA
- Q(2,I)=-HA/(H2A*H2)
- Q(3,I)=-H*H2A/H3A
- F(1,I)=(Y0-H*B0)/(H*HA)
- F(2,I)=(H2B-Y0*(2.0d0*H-A0))/(H*H2*H2A)
- F(3,I)=-(H2B-3.0d0*Y0*HA)/(H*H3A)
- A0=Q(3,I)
- B0=F(3,I)
- enddo
-
-! TAKE CARE OF LAST TWO ROWS.
- I=J2+1
- H=X(I+1)-X(I)
- Y0=Y(I+1)-Y(I)
- H2=H*H
- HA=H-A0
- H2A=H*HA
- H2B=H2*B0-Y0*(2.0d0*H-A0)
- Q(1,I)=H2/HA
- F(1,I)=(Y0-H*B0)/H2A
- HA=X(J2)-X(I+1)
- Y0=-H*HA*(HA+H)
- HA=HA*HA
-
-! CALCULATE DERIVATIVE AT FAR END.
- Y0=(Y(I+1)*(H2-HA)+Y(I)*HA-Y(J2)*H2)/Y0
- Q(3,I)=(Y0*H2A+H2B)/(H*H2*(H-2.0d0*A0))
- Q(2,I)=F(1,I)-Q(1,I)*Q(3,I)
-
-! SOLVE UPPER BANDED MATRIX BY REVERSE ITERATION.
- DO J=J1,J2
- K=I-1
- Q(1,I)=F(3,K)-Q(3,K)*Q(2,I)
- Q(3,K)=F(2,K)-Q(2,K)*Q(1,I)
- Q(2,K)=F(1,K)-Q(1,K)*Q(3,K)
- I=K
- enddo
- Q(1,I)=B1
-! FILL IN THE LAST POINT WITH A LINEAR EXTRAPOLATION.
- 9 J2=J2+2
- DO J=1,3
- Q(J,J2)=YY(J)
- enddo
-
-! SEE IF THIS DISCONTINUITY IS THE LAST.
- 12 IF(J2-I2 < 0) then
- goto 6
- else
- return
- endif
-
-! NO. GO BACK FOR MORE.
- 6 J1=J2+2
- IF(J1-I2 <= 0) goto 8
- IF(J1-I2 > 0) goto 7
-
-! THERE IS ONLY ONE POINT LEFT AFTER THE LATEST DISCONTINUITY.
- 7 DO J=1,3
- Q(J,I2)=YY(J)
- enddo
-
- end subroutine rspln
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/memory_eval.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/memory_eval.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/memory_eval.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,351 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! compute the approximate amount of static memory needed to run the solver
-
- subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
- TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
- ONE_CRUST,doubling_index,this_region_has_a_doubling,&
- ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
- NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
- NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
-
- implicit none
-
- include "constants.h"
-
-! input
- logical, intent(in) :: TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- ROTATION,ATTENUATION,ONE_CRUST,OCEANS,ABSORBING_CONDITIONS,MOVIE_VOLUME,SAVE_FORWARD
- integer, dimension(MAX_NUM_REGIONS), intent(in) :: NSPEC, nglob
- integer, intent(in) :: NEX_PER_PROC_XI,NEX_PER_PROC_ETA,SIMULATION_TYPE
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: doubling_index
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: this_region_has_a_doubling
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: ner,ratio_sampling_array
-
-! output
- double precision, intent(out) :: static_memory_size
-
-! variables
- integer :: ilayer,NUMBER_OF_MESH_LAYERS,ner_without_doubling,ispec_aniso
-
- integer, intent(out) :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
-
-! generate the elements in all the regions of the mesh
- ispec_aniso = 0
-
- if (ONE_CRUST) then
- NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS - 1
- else
- NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS
- endif
-
-! count anisotropic elements
- do ilayer = 1, NUMBER_OF_MESH_LAYERS
- if(doubling_index(ilayer) == IFLAG_220_80 .or. doubling_index(ilayer) == IFLAG_80_MOHO) then
- ner_without_doubling = ner(ilayer)
- if(this_region_has_a_doubling(ilayer)) then
- ner_without_doubling = ner_without_doubling - 2
- ispec_aniso = ispec_aniso + &
- (NSPEC_DOUBLING_SUPERBRICK*(NEX_PER_PROC_XI/ratio_sampling_array(ilayer)/2)* &
- (NEX_PER_PROC_ETA/ratio_sampling_array(ilayer)/2))
- endif
- ispec_aniso = ispec_aniso + &
- ((NEX_PER_PROC_XI/ratio_sampling_array(ilayer))*(NEX_PER_PROC_ETA/ratio_sampling_array(ilayer))*ner_without_doubling)
- endif
- enddo
-
-! define static size of the arrays whose size depends on logical tests
-
- if(ANISOTROPIC_INNER_CORE) then
- NSPECMAX_ANISO_IC = NSPEC(IREGION_INNER_CORE)
- else
- NSPECMAX_ANISO_IC = 1
- endif
-
- if(ANISOTROPIC_3D_MANTLE) then
- NSPECMAX_ISO_MANTLE = 1
- NSPECMAX_TISO_MANTLE = 1
- NSPECMAX_ANISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
- else
-
- NSPECMAX_ISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
- if(TRANSVERSE_ISOTROPY) then
- NSPECMAX_TISO_MANTLE = ispec_aniso
- else
- NSPECMAX_TISO_MANTLE = 1
- endif
-
- NSPECMAX_ANISO_MANTLE = 1
- endif
-
-! if attenuation is off, set dummy size of arrays to one
- if(ATTENUATION) then
- NSPEC_CRUST_MANTLE_ATTENUAT = NSPEC(IREGION_CRUST_MANTLE)
- NSPEC_INNER_CORE_ATTENUATION = NSPEC(IREGION_INNER_CORE)
- else
- NSPEC_CRUST_MANTLE_ATTENUAT = 1
- NSPEC_INNER_CORE_ATTENUATION = 1
- endif
-
- if(ATTENUATION .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
- NSPEC_CRUST_MANTLE_STR_OR_ATT = NSPEC(IREGION_CRUST_MANTLE)
- NSPEC_INNER_CORE_STR_OR_ATT = NSPEC(IREGION_INNER_CORE)
- else
- NSPEC_CRUST_MANTLE_STR_OR_ATT = 1
- NSPEC_INNER_CORE_STR_OR_ATT = 1
- endif
-
- if(ATTENUATION .and. SIMULATION_TYPE == 3) then
- NSPEC_CRUST_MANTLE_STR_AND_ATT = NSPEC(IREGION_CRUST_MANTLE)
- NSPEC_INNER_CORE_STR_AND_ATT = NSPEC(IREGION_INNER_CORE)
- else
- NSPEC_CRUST_MANTLE_STR_AND_ATT = 1
- NSPEC_INNER_CORE_STR_AND_ATT = 1
- endif
-
-
- if(SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
- NSPEC_CRUST_MANTLE_STRAIN_ONLY = NSPEC(IREGION_CRUST_MANTLE)
- NSPEC_INNER_CORE_STRAIN_ONLY = NSPEC(IREGION_INNER_CORE)
- else
- NSPEC_CRUST_MANTLE_STRAIN_ONLY = 1
- NSPEC_INNER_CORE_STRAIN_ONLY = 1
- endif
-
- if ((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then
- NSPEC_CRUST_MANTLE_ADJOINT = NSPEC(IREGION_CRUST_MANTLE)
- NSPEC_OUTER_CORE_ADJOINT = NSPEC(IREGION_OUTER_CORE)
- NSPEC_INNER_CORE_ADJOINT = NSPEC(IREGION_INNER_CORE)
-
- NGLOB_CRUST_MANTLE_ADJOINT = NGLOB(IREGION_CRUST_MANTLE)
- NGLOB_OUTER_CORE_ADJOINT = NGLOB(IREGION_OUTER_CORE)
- NGLOB_INNER_CORE_ADJOINT = NGLOB(IREGION_INNER_CORE)
-
- if(ROTATION) then
- NSPEC_OUTER_CORE_ROT_ADJOINT = NSPEC(IREGION_OUTER_CORE)
- else
- NSPEC_OUTER_CORE_ROT_ADJOINT = 1
- endif
- else
- NSPEC_CRUST_MANTLE_ADJOINT = 1
- NSPEC_OUTER_CORE_ADJOINT = 1
- NSPEC_INNER_CORE_ADJOINT = 1
-
- NGLOB_CRUST_MANTLE_ADJOINT = 1
- NGLOB_OUTER_CORE_ADJOINT = 1
- NGLOB_INNER_CORE_ADJOINT = 1
-
- NSPEC_OUTER_CORE_ROT_ADJOINT = 1
- endif
-
-! if absorbing conditions are off, set dummy size of arrays to one
- if(ABSORBING_CONDITIONS) then
- NSPEC_CRUST_MANTLE_STACEY = NSPEC(IREGION_CRUST_MANTLE)
- NSPEC_OUTER_CORE_STACEY = NSPEC(IREGION_OUTER_CORE)
- else
- NSPEC_CRUST_MANTLE_STACEY = 1
- NSPEC_OUTER_CORE_STACEY = 1
- endif
-
-! if oceans are off, set dummy size of arrays to one
- if(OCEANS) then
- NGLOB_CRUST_MANTLE_OCEANS = NGLOB(IREGION_CRUST_MANTLE)
- else
- NGLOB_CRUST_MANTLE_OCEANS = 1
- endif
-
- if(ROTATION) then
- NSPEC_OUTER_CORE_ROTATION = NSPEC(IREGION_OUTER_CORE)
- else
- NSPEC_OUTER_CORE_ROTATION = 1
- endif
-
-! add size of each set of static arrays multiplied by the number of such arrays
-
- static_memory_size = 0.d0
-
-! R_memory_crust_mantle
- static_memory_size = static_memory_size + 5.d0*dble(N_SLS)*dble(NGLLX)* &
- dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ATTENUAT*dble(CUSTOM_REAL)
-
-! R_memory_inner_core
- static_memory_size = static_memory_size + 5.d0*dble(N_SLS)*dble(NGLLX)* &
- dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ATTENUATION*dble(CUSTOM_REAL)
-
-! 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
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*9.d0*dble(CUSTOM_REAL)
-
-! ibool_crust_mantle
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*dble(SIZE_INTEGER)
-
-! 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
-! kappavstore_outer_core
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*10.d0*dble(CUSTOM_REAL)
-
-! ibool_outer_core
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*dble(SIZE_INTEGER)
-
-! idoubling_crust_mantle
- static_memory_size = static_memory_size + NSPEC(IREGION_CRUST_MANTLE)*dble(SIZE_INTEGER)
-
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,rmass_crust_mantle
- static_memory_size = static_memory_size + NGLOB(IREGION_CRUST_MANTLE)*4.d0*dble(CUSTOM_REAL)
-
-! kappavstore_crust_mantle,muvstore_crust_mantle
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ISO_MANTLE*2.d0*dble(CUSTOM_REAL)
-
-! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_TISO_MANTLE*3.d0*dble(CUSTOM_REAL)
-
-! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,
-! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle,
-! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle,
-! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle,
-! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle,
-! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle,
-! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ANISO_MANTLE*21.d0*dble(CUSTOM_REAL)
-
-! displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
- static_memory_size = static_memory_size + dble(NDIM)*NGLOB(IREGION_CRUST_MANTLE)*3.d0*dble(CUSTOM_REAL)
-
-! xstore_outer_core, ystore_outer_core, zstore_outer_core, rmass_outer_core, displ_outer_core, veloc_outer_core, accel_outer_core
- static_memory_size = static_memory_size + NGLOB(IREGION_OUTER_CORE)*7.d0*dble(CUSTOM_REAL)
-
-! ibool_inner_core
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_INNER_CORE)*dble(SIZE_INTEGER)
-
-! 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
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_INNER_CORE)*11.d0*dble(CUSTOM_REAL)
-
-! xstore_inner_core,ystore_inner_core,zstore_inner_core,rmass_inner_core
- static_memory_size = static_memory_size + NGLOB(IREGION_INNER_CORE)*4.d0*dble(CUSTOM_REAL)
-
-! c11store_inner_core,c33store_inner_core,c12store_inner_core,c13store_inner_core,c44store_inner_core
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ANISO_IC*5.d0*dble(CUSTOM_REAL)
-
-! displ_inner_core,veloc_inner_core,accel_inner_core
- static_memory_size = static_memory_size + dble(NDIM)*NGLOB(IREGION_INNER_CORE)*3.d0*dble(CUSTOM_REAL)
-
-! A_array_rotation,B_array_rotation
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ROTATION*2.d0*dble(CUSTOM_REAL)
-
- if(ABSORBING_CONDITIONS) then
-
-! rho_vp_crust_mantle,rho_vs_crust_mantle
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*2.d0*dble(CUSTOM_REAL)
-
-! vp_outer_core
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*dble(CUSTOM_REAL)
-
- endif
-
- if(OCEANS) then
-
-! rmass_ocean_load
- static_memory_size = static_memory_size + NGLOB(IREGION_CRUST_MANTLE)*dble(CUSTOM_REAL)
-
- endif
-
-! add arrays used to save strain for attenuation or for adjoint runs
-
-! epsilondev_crust_mantle
- static_memory_size = static_memory_size + 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
-
-! eps_trace_over_3_crust_mantle
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
-
-! epsilondev_inner_core
- static_memory_size = static_memory_size + 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
-
-! eps_trace_over_3_inner_core
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
-
-! add arrays used for adjoint runs only (LQY: not very accurate)
-
-! b_R_memory_crust_mantle
-! b_epsilondev_crust_mantle
-! b_eps_trace_over_3_crust_mantle
-! rho_kl_crust_mantle,beta_kl_crust_mantle, alpha_kl_crust_mantle
- static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 9.d0)* &
- dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ADJOINT*dble(CUSTOM_REAL)
-
-! b_div_displ_outer_core
-! rho_kl_outer_core,alpha_kl_outer_core
- static_memory_size = static_memory_size + 3.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ADJOINT*dble(CUSTOM_REAL)
-
-! b_R_memory_inner_core
-! b_epsilondev_inner_core
-! b_eps_trace_over_3_inner_core
-! rho_kl_inner_core,beta_kl_inner_core, alpha_kl_inner_core
- static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 9.d0)* &
- dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ADJOINT*dble(CUSTOM_REAL)
-
-! b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
- static_memory_size = static_memory_size + 3.d0*dble(NDIM)*NGLOB_CRUST_MANTLE_ADJOINT*dble(CUSTOM_REAL)
-
-! b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
- static_memory_size = static_memory_size + 3.d0*NGLOB_OUTER_CORE_ADJOINT*dble(CUSTOM_REAL)
-
-! b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
- static_memory_size = static_memory_size + 3.d0*dble(NDIM)*NGLOB_INNER_CORE_ADJOINT*dble(CUSTOM_REAL)
-
-! b_A_array_rotation,b_B_array_rotation
- static_memory_size = static_memory_size + 2.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ROT_ADJOINT*dble(CUSTOM_REAL)
-
- end subroutine memory_eval
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/meshfem3D.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/meshfem3D.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,2150 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 Government Sponsorship Acknowledged.
-
- program xmeshfem3D
-
- 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 "OUTPUT_FILES/values_from_mesher.h"
-
-!=====================================================================!
-! !
-! 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. !
-! !
-!=====================================================================!
-!
-! 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 caltech.edu> and/or use our online
-! bug tracking system at http://www.geodynamics.org/roundup .
-!
-! Evolution of the code:
-! ---------------------
-!
-! 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, seismos can be
-! written by the master
-! v. 3.6 Many people, many affiliations, September 2006:
-! adjoint and kernel calculations, 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
-! 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, 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 CM5
-!
-
-! 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(:), pointer :: 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_aniso,npointot
-
-! parameters needed to store the radii of the grid points
-! in the spherically symmetric Earth
-!! DK DK suppressed this for merged version
-! integer, dimension(:), allocatable :: idoubling
-! integer, dimension(:,:,:,:), allocatable :: ibool
-
-! arrays with the mesh in double precision
- double precision, dimension(:,:,:,:), allocatable :: xstore,ystore,zstore
-
-! proc numbers for MPI
- integer myrank,sizeprocs,ier,errorcode
-
-! 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
- integer, dimension(:), allocatable :: ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta
- double precision, dimension(:), allocatable :: xread1D_leftxi_lefteta,xread1D_rightxi_lefteta, &
- xread1D_leftxi_righteta,xread1D_rightxi_righteta
- double precision, dimension(:), allocatable :: yread1D_leftxi_lefteta,yread1D_rightxi_lefteta, &
- yread1D_leftxi_righteta,yread1D_rightxi_righteta
- double precision, dimension(:), allocatable :: 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(:), allocatable :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
- integer, dimension(:,:,:), allocatable :: 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
-
- 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,LOCAL_PATH,MODEL
-
-! parameters deduced from parameters read from file
- integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, 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
-
-! DK DK UGLY if running on MareNostrum in Barcelona
- integer :: sender, receiver, dummy1, dummy2
- integer msg_status(MPI_STATUS_SIZE)
- character(len=400) system_command
-
-! computed in read_compute_parameters
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-! memory size of all the static arrays
-! double precision :: static_memory_size
-
-! arrays for BCAST
- integer, dimension(38) :: 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)
-
- integer :: ipass
-
-!! DK DK suppressed this for the merged version
-! integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
-! NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
-! NSPEC_INNER_CORE_ATTENUATION, &
-! NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
-! NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
-! NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
-! NSPEC_CRUST_MANTLE_ADJOINT, &
-! NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
-! NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
-! NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
-! NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
-! NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
-
-! 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
-! integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
-
-!! DK DK for the merged version
- include 'declar.f90'
-
-!! DK DK added this for the merged version
-!---- arrays to assemble between chunks
-
- integer :: imsg
-
-! 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
-
- logical :: not_done_yet
-
-! ************** PROGRAM STARTS HERE **************
-
-! initialize the MPI communicator and start the NPROCTOT MPI processes.
- call MPI_INIT(ier)
-
-! 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)
-
-! 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')
-
-! 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,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
-
- if(err_occurred() /= 0) then
- call exit_MPI(myrank,'an error occurred while reading the parameter file')
- endif
-
-! 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/)
-
- 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(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(bcast_integer,38,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(LOCAL_PATH,150,MPI_CHARACTER,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_region_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)
-
- 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
-
-! DK DK UGLY if running on MareNostrum in Barcelona
- if(RUN_ON_MARENOSTRUM_BARCELONA) then
-
-! check that we combine the seismograms in one large file to avoid GPFS overloading
- if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) call exit_MPI(myrank,'should use SAVE_ALL_SEISMOS_IN_ONE_FILE for GPFS in Barcelona')
-
-! clean the local scratch space using a cascade (serial removal, one process after the other)
- if(myrank == 0) then
-
- receiver = myrank + 1
- call system('rm -f -r /scratch/komatits_new* > /dev/null')
- call MPI_SEND(dummy1,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
-
- else
-
- sender = myrank - 1
- receiver = myrank + 1
- call MPI_RECV(dummy2,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- call system('rm -f -r /scratch/komatits_new* > /dev/null')
- if(myrank < sizeprocs - 1) call MPI_SEND(dummy1,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
-
- endif
-
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-! use the local scratch disk to save all the files, ignore the path that is given in the Par_file
- LOCAL_PATH = '/scratch/komatits_new'
-
-! add processor name to local /scratch/komatits_new path
- write(system_command,"('_proc',i4.4)") myrank
- LOCAL_PATH = trim(LOCAL_PATH) // trim(system_command)
-
-! create a local directory to store all the local files
- write(system_command,"('mkdir /scratch/komatits_new_proc',i4.4)") myrank
- call system(system_command)
-
- 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')
-
-! dynamic allocation of mesh arrays
- allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(ichunk_slice(0:NPROCTOT-1),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(iproc_xi_slice(0:NPROCTOT-1),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(iproc_eta_slice(0:NPROCTOT-1),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- 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
-!! DK DK suppressed this for merged
-!! DK DK suppressed this for merged open(unit=IOUT,file=trim(OUTPUT_FILES)//'/addressing.txt',status='unknown')
- 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
-!! DK DK suppressed this for merged
-!! DK DK suppressed this for merged if(myrank == 0) write(IOUT,*) iprocnum,ichunk,iproc_xi,iproc_eta
- enddo
- enddo
- enddo
-!! DK DK suppressed this for merged
-!! DK DK suppressed this for merged if(myrank == 0) close(IOUT)
-
-!! DK DK added this for the merged version
- not_done_yet = .true.
-
-! 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)
-
- if(myrank /= 0) then
- allocate(AM_V%Qtau_s(N_SLS),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- endif
- 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
-
-! make sure everybody is synchronized
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-!----
-!---- loop on all the regions of the mesh
-!----
-
-!! DK DK for the merged version
- include 'allocate_before.f90'
-
-!! DK DK for the merged version
- allocate(ibool1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(ibool1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(ibool1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(ibool1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(xread1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(xread1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(xread1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(xread1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(yread1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(yread1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(yread1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(yread1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(zread1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(zread1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(zread1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(zread1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-! 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
-
-! use dynamic allocation to allocate memory for arrays
-!! DK DK suppressed this for merged version
-! allocate(idoubling(NSPEC(iregion_code)),STAT=ier)
-! allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
- allocate(xstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(ystore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
- allocate(zstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
- if (ier /= 0) then
- print *,"ABORTING can not allocate in meshfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-! create all the regions of the mesh
-! perform two passes in this part to be able to save memory
- do ipass = 1,2
-
-!! 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_aniso, &
- 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, &
- max(NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
- myrank,LOCAL_PATH,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_region_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,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
- 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),perm,invperm)
-
- 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_aniso, &
- 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, &
- max(NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
- myrank,LOCAL_PATH,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_region_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,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
- 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),perm,invperm)
-
- 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_aniso, &
- 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, &
- max(NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
- myrank,LOCAL_PATH,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_region_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,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
- 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),perm,invperm)
-
- else
- stop 'DK DK incorrect region in merged code'
- endif
-
- enddo ! of loop on ipass = 1,2
-
-! store number of anisotropic elements found in the mantle
- if(nspec_aniso /= 0 .and. iregion_code /= IREGION_CRUST_MANTLE) &
- call exit_MPI(myrank,'found anisotropic elements outside of the mantle')
-
- if(iregion_code == IREGION_CRUST_MANTLE .and. nspec_aniso == 0) &
- call exit_MPI(myrank,'found no anisotropic elements in the mantle')
-
-! use MPI reduction to compute total area and volume
- 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
-
-!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-!! DK DK added this for merged version
-
-! create the list of messages in files to assemble between chunks if more than one chunk
-! create it only once (and for all) therefore for first region only, because stored in disk files
-!! DK DK this could probably be simplified or merged with create_chunk_buffers, but no time to do it for now
- if(NCHUNKS > 1 .and. iregion_code == IREGION_CRUST_MANTLE) &
-! crust_mantle
- call create_list_files_chunks(iregion_code, &
- nglob(iregion_code),NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_CORNER, &
- myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS)
-
-!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-!! DK DK added this for merged version
-
-! read chunk messages only if more than one chunk
- if(NCHUNKS_VAL /= 1 .and. myrank == 0 .and. not_done_yet) then
-
-! do this only once in the mesher, because these arrays do not change
- not_done_yet = .false.
-
-! read messages to assemble between chunks with MPI
-
-! file with the list of processors for each message for faces
- open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='old',action='read')
- do imsg = 1,NUMMSGS_FACES_VAL
- read(IIN,*) imsg_type(imsg),iprocfrom_faces(imsg),iprocto_faces(imsg)
- if (iprocfrom_faces(imsg) < 0 &
- .or. iprocto_faces(imsg) < 0 &
- .or. iprocfrom_faces(imsg) > NPROCTOT-1 &
- .or. iprocto_faces(imsg) > NPROCTOT-1) &
- call exit_MPI(myrank,'incorrect chunk faces numbering')
- if (imsg_type(imsg) < 1 .or. imsg_type(imsg) > 3) &
- call exit_MPI(myrank,'incorrect message type labeling')
- enddo
- close(IIN)
-
-! file with the list of processors for each message for corners
- open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='old',action='read')
- do imsg = 1,NCORNERSCHUNKS_VAL
- read(IIN,*) iproc_master_corners(imsg),iproc_worker1_corners(imsg), &
- iproc_worker2_corners(imsg)
- if (iproc_master_corners(imsg) < 0 &
- .or. iproc_worker1_corners(imsg) < 0 &
- .or. iproc_worker2_corners(imsg) < 0 &
- .or. iproc_master_corners(imsg) > NPROCTOT-1 &
- .or. iproc_worker1_corners(imsg) > NPROCTOT-1 &
- .or. iproc_worker2_corners(imsg) > NPROCTOT-1) &
- call exit_MPI(myrank,'incorrect chunk corner numbering')
- enddo
- close(IIN)
-
- endif
-
-! broadcast the information read on the master to the nodes
- if(NCHUNKS_VAL /= 1) then
- call MPI_BCAST(imsg_type,NUMMSGS_FACES_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iprocfrom_faces,NUMMSGS_FACES_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iprocto_faces,NUMMSGS_FACES_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(iproc_master_corners,NCORNERSCHUNKS_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iproc_worker1_corners,NCORNERSCHUNKS_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iproc_worker2_corners,NCORNERSCHUNKS_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- 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,LOCAL_PATH,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,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,LOCAL_PATH,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,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,LOCAL_PATH,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,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
-
-! deallocate arrays used for that region
-!! DK DK suppressed this for merged version
-! deallocate(idoubling)
-! deallocate(ibool)
- deallocate(xstore)
- deallocate(ystore)
- deallocate(zstore)
-
-! make sure everybody is synchronized
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-! end of loop on all the regions
- enddo
-
-!! DK DK for the merged version
- deallocate(ibool1D_leftxi_lefteta)
- deallocate(ibool1D_rightxi_lefteta)
- deallocate(ibool1D_leftxi_righteta)
- deallocate(ibool1D_rightxi_righteta)
-
- deallocate(xread1D_leftxi_lefteta)
- deallocate(xread1D_rightxi_lefteta)
- deallocate(xread1D_leftxi_righteta)
- deallocate(xread1D_rightxi_righteta)
-
- deallocate(yread1D_leftxi_lefteta)
- deallocate(yread1D_rightxi_lefteta)
- deallocate(yread1D_leftxi_righteta)
- deallocate(yread1D_rightxi_righteta)
-
- deallocate(zread1D_leftxi_lefteta)
- deallocate(zread1D_rightxi_lefteta)
- deallocate(zread1D_leftxi_righteta)
- deallocate(zread1D_rightxi_righteta)
-
- 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,*)
-
-! evaluate the amount of static memory needed by the solver
-!! DK DK suppressed in the merged version because useless
-! call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
-! TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
-! ONE_CRUST,doubling_index,this_region_has_a_doubling,&
-! ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
-! NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
-! NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
-! NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
-! NSPEC_INNER_CORE_ATTENUATION, &
-! NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
-! NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
-! NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
-! NSPEC_CRUST_MANTLE_ADJOINT, &
-! NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
-! NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
-! NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
-! NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
-! NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
-
-!! DK DK suppressed in the merged version because useless
-! NGLOB1D_RADIAL_TEMP(:) = &
-! (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
-
-! create include file for the solver
-!! DK DK suppressed in the merged version because useless
-! call save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
-! TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
-! ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
-! ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
-! INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP, &
-! static_memory_size,NGLOB1D_RADIAL_TEMP, &
-! NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
-! NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
-! NPROC_XI,NPROC_ETA, &
-! NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
-! NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
-! NSPEC_INNER_CORE_ATTENUATION, &
-! NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
-! NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
-! NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
-! NSPEC_CRUST_MANTLE_ADJOINT, &
-! NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
-! NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
-! NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
-! NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
-! NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
-
- endif ! end of section executed by main process only
-
-! deallocate arrays used for mesh generation
-!! DK DK suppressed in the merged version because these arrays will be transmitted to the solver
-! deallocate(addressing)
-! deallocate(ichunk_slice)
-! deallocate(iproc_xi_slice)
-! deallocate(iproc_eta_slice)
-
-! 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
-
-! synchronize all the processes to make sure everybody has finished
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-!!!!!!!! DK DK solver inserted here
-!!!!!!!! DK DK solver inserted here
-!!!!!!!! DK DK solver inserted here
-
-!! 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 for the merged version
- include 'allocate_after_1.f90'
-
-!! 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)
-
- 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)
-
- 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)
-
-!! 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)
-
-!! DK DK for the merged version
- include 'allocate_after_2.f90'
-
-!! DK DK for the merged version
- include 'call1.f90'
-!! DK DK for now use variables just to make sure we don't get warning about unused variables
-! include 'oldstuff/dummy_use_variables.f90'
-
-!! DK DK for the merged version
- include 'deallocate.f90'
-
-!!!!!!!! DK DK solver inserted here
-!!!!!!!! DK DK solver inserted here
-!!!!!!!! DK DK solver inserted here
-
-! 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 xmeshfem3D
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_1066a.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_1066a.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_1066a.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,1131 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 model_1066a(x,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V)
-
- implicit none
-
- include "constants.h"
-
-! 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
-
-! input:
-! radius r: meters
-
-! output:
-! density rho: kg/m^3
-! compressional wave speed vp: km/s
-! shear wave speed vs: km/s
-
- integer iregion_code
-
- double precision x,rho,vp,vs,Qmu,Qkappa
-
- integer i
-
- double precision r,frac,scaleval
-
-! compute real physical radius in meters
- r = x * R_EARTH
-
- i = 1
- do while(r >= M1066a_V%radius_1066a(i) .and. i /= NR_1066A)
- i = i + 1
- enddo
-
-! make sure we stay in the right region and never take a point above
-! and a point below the ICB or the CMB and interpolate between them,
-! which would lead to a wrong value (keeping in mind that we interpolate
-! between points i-1 and i below)
- if(iregion_code == IREGION_INNER_CORE .and. i > 33) i = 33
-
- if(iregion_code == IREGION_OUTER_CORE .and. i < 35) i = 35
- if(iregion_code == IREGION_OUTER_CORE .and. i > 66) i = 66
-
- if(iregion_code == IREGION_CRUST_MANTLE .and. i < 68) i = 68
-
- if(i == 1) then
- rho = M1066a_V%density_1066a(i)
- vp = M1066a_V%vp_1066a(i)
- vs = M1066a_V%vs_1066a(i)
- Qmu = M1066a_V%Qmu_1066a(i)
- Qkappa = M1066a_V%Qkappa_1066a(i)
- else
-
-! interpolate from radius_1066a(i-1) to r using the values at i-1 and i
- frac = (r-M1066a_V%radius_1066a(i-1))/(M1066a_V%radius_1066a(i)-M1066a_V%radius_1066a(i-1))
-
- rho = M1066a_V%density_1066a(i-1) + frac * (M1066a_V%density_1066a(i)-M1066a_V%density_1066a(i-1))
- vp = M1066a_V%vp_1066a(i-1) + frac * (M1066a_V%vp_1066a(i)-M1066a_V%vp_1066a(i-1))
- vs = M1066a_V%vs_1066a(i-1) + frac * (M1066a_V%vs_1066a(i)-M1066a_V%vs_1066a(i-1))
- Qmu = M1066a_V%Qmu_1066a(i-1) + frac * (M1066a_V%Qmu_1066a(i)-M1066a_V%Qmu_1066a(i-1))
- Qkappa = M1066a_V%Qkappa_1066a(i-1) + frac * (M1066a_V%Qkappa_1066a(i)-M1066a_V%Qkappa_1066a(i-1))
-
- endif
-
-! make sure Vs is zero in the outer core even if roundoff errors on depth
-! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
- if(iregion_code == IREGION_OUTER_CORE) then
- vs = 0.d0
- Qkappa = 3000.d0
- Qmu = 3000.d0
- endif
-
-! non-dimensionalize
-! time scaling (s^{-1}) is done with scaleval
- scaleval=dsqrt(PI*GRAV*RHOAV)
- rho=rho*1000.0d0/RHOAV
- vp=vp*1000.0d0/(R_EARTH*scaleval)
- vs=vs*1000.0d0/(R_EARTH*scaleval)
-
- end subroutine model_1066a
-
-!-------------------
-
- subroutine define_model_1066a(USE_EXTERNAL_CRUSTAL_MODEL,M1066a_V)
-
- implicit none
- include "constants.h"
-
-! 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
-
- logical USE_EXTERNAL_CRUSTAL_MODEL
-
- integer i
-
-! define all the values in the model
-
- M1066a_V%radius_1066a( 1) = 0.000000000000000
- M1066a_V%radius_1066a( 2) = 38400.0000000000
- M1066a_V%radius_1066a( 3) = 76810.0000000000
- M1066a_V%radius_1066a( 4) = 115210.000000000
- M1066a_V%radius_1066a( 5) = 153610.000000000
- M1066a_V%radius_1066a( 6) = 192020.000000000
- M1066a_V%radius_1066a( 7) = 230420.000000000
- M1066a_V%radius_1066a( 8) = 268820.000000000
- M1066a_V%radius_1066a( 9) = 307220.000000000
- M1066a_V%radius_1066a( 10) = 345630.000000000
- M1066a_V%radius_1066a( 11) = 384030.000000000
- M1066a_V%radius_1066a( 12) = 422430.000000000
- M1066a_V%radius_1066a( 13) = 460840.000000000
- M1066a_V%radius_1066a( 14) = 499240.000000000
- M1066a_V%radius_1066a( 15) = 537640.000000000
- M1066a_V%radius_1066a( 16) = 576050.000000000
- M1066a_V%radius_1066a( 17) = 614450.000000000
- M1066a_V%radius_1066a( 18) = 652850.000000000
- M1066a_V%radius_1066a( 19) = 691260.000000000
- M1066a_V%radius_1066a( 20) = 729660.000000000
- M1066a_V%radius_1066a( 21) = 768060.000000000
- M1066a_V%radius_1066a( 22) = 806460.000000000
- M1066a_V%radius_1066a( 23) = 844870.000000000
- M1066a_V%radius_1066a( 24) = 883270.000000000
- M1066a_V%radius_1066a( 25) = 921670.000000000
- M1066a_V%radius_1066a( 26) = 960080.000000000
- M1066a_V%radius_1066a( 27) = 998480.000000000
- M1066a_V%radius_1066a( 28) = 1036880.00000000
- M1066a_V%radius_1066a( 29) = 1075290.00000000
- M1066a_V%radius_1066a( 30) = 1113690.00000000
- M1066a_V%radius_1066a( 31) = 1152090.00000000
- M1066a_V%radius_1066a( 32) = 1190500.00000000
- M1066a_V%radius_1066a( 33) = 1229480.00000000
- M1066a_V%radius_1066a( 34) = 1229480.00000000
- M1066a_V%radius_1066a( 35) = 1299360.00000000
- M1066a_V%radius_1066a( 36) = 1369820.00000000
- M1066a_V%radius_1066a( 37) = 1440280.00000000
- M1066a_V%radius_1066a( 38) = 1510740.00000000
- M1066a_V%radius_1066a( 39) = 1581190.00000000
- M1066a_V%radius_1066a( 40) = 1651650.00000000
- M1066a_V%radius_1066a( 41) = 1722110.00000000
- M1066a_V%radius_1066a( 42) = 1792570.00000000
- M1066a_V%radius_1066a( 43) = 1863030.00000000
- M1066a_V%radius_1066a( 44) = 1933490.00000000
- M1066a_V%radius_1066a( 45) = 2003950.00000000
- M1066a_V%radius_1066a( 46) = 2074410.00000000
- M1066a_V%radius_1066a( 47) = 2144870.00000000
- M1066a_V%radius_1066a( 48) = 2215330.00000000
- M1066a_V%radius_1066a( 49) = 2285790.00000000
- M1066a_V%radius_1066a( 50) = 2356240.00000000
- M1066a_V%radius_1066a( 51) = 2426700.00000000
- M1066a_V%radius_1066a( 52) = 2497160.00000000
- M1066a_V%radius_1066a( 53) = 2567620.00000000
- M1066a_V%radius_1066a( 54) = 2638080.00000000
- M1066a_V%radius_1066a( 55) = 2708540.00000000
- M1066a_V%radius_1066a( 56) = 2779000.00000000
- M1066a_V%radius_1066a( 57) = 2849460.00000000
- M1066a_V%radius_1066a( 58) = 2919920.00000000
- M1066a_V%radius_1066a( 59) = 2990380.00000000
- M1066a_V%radius_1066a( 60) = 3060840.00000000
- M1066a_V%radius_1066a( 61) = 3131300.00000000
- M1066a_V%radius_1066a( 62) = 3201750.00000000
- M1066a_V%radius_1066a( 63) = 3272210.00000000
- M1066a_V%radius_1066a( 64) = 3342670.00000000
- M1066a_V%radius_1066a( 65) = 3413130.00000000
- M1066a_V%radius_1066a( 66) = 3484300.00000000
- M1066a_V%radius_1066a( 67) = 3484300.00000000
- M1066a_V%radius_1066a( 68) = 3518220.00000000
- M1066a_V%radius_1066a( 69) = 3552850.00000000
- M1066a_V%radius_1066a( 70) = 3587490.00000000
- M1066a_V%radius_1066a( 71) = 3622120.00000000
- M1066a_V%radius_1066a( 72) = 3656750.00000000
- M1066a_V%radius_1066a( 73) = 3691380.00000000
- M1066a_V%radius_1066a( 74) = 3726010.00000000
- M1066a_V%radius_1066a( 75) = 3760640.00000000
- M1066a_V%radius_1066a( 76) = 3795270.00000000
- M1066a_V%radius_1066a( 77) = 3829910.00000000
- M1066a_V%radius_1066a( 78) = 3864540.00000000
- M1066a_V%radius_1066a( 79) = 3899170.00000000
- M1066a_V%radius_1066a( 80) = 3933800.00000000
- M1066a_V%radius_1066a( 81) = 3968430.00000000
- M1066a_V%radius_1066a( 82) = 4003060.00000000
- M1066a_V%radius_1066a( 83) = 4037690.00000000
- M1066a_V%radius_1066a( 84) = 4072330.00000000
- M1066a_V%radius_1066a( 85) = 4106960.00000000
- M1066a_V%radius_1066a( 86) = 4141590.00000000
- M1066a_V%radius_1066a( 87) = 4176220.00000000
- M1066a_V%radius_1066a( 88) = 4210850.00000000
- M1066a_V%radius_1066a( 89) = 4245480.00000000
- M1066a_V%radius_1066a( 90) = 4280110.00000000
- M1066a_V%radius_1066a( 91) = 4314740.00000000
- M1066a_V%radius_1066a( 92) = 4349380.00000000
- M1066a_V%radius_1066a( 93) = 4384010.00000000
- M1066a_V%radius_1066a( 94) = 4418640.00000000
- M1066a_V%radius_1066a( 95) = 4453270.00000000
- M1066a_V%radius_1066a( 96) = 4487900.00000000
- M1066a_V%radius_1066a( 97) = 4522530.00000000
- M1066a_V%radius_1066a( 98) = 4557160.00000000
- M1066a_V%radius_1066a( 99) = 4591800.00000000
- M1066a_V%radius_1066a(100) = 4626430.00000000
- M1066a_V%radius_1066a(101) = 4661060.00000000
- M1066a_V%radius_1066a(102) = 4695690.00000000
- M1066a_V%radius_1066a(103) = 4730320.00000000
- M1066a_V%radius_1066a(104) = 4764950.00000000
- M1066a_V%radius_1066a(105) = 4799580.00000000
- M1066a_V%radius_1066a(106) = 4834220.00000000
- M1066a_V%radius_1066a(107) = 4868850.00000000
- M1066a_V%radius_1066a(108) = 4903480.00000000
- M1066a_V%radius_1066a(109) = 4938110.00000000
- M1066a_V%radius_1066a(110) = 4972740.00000000
- M1066a_V%radius_1066a(111) = 5007370.00000000
- M1066a_V%radius_1066a(112) = 5042000.00000000
- M1066a_V%radius_1066a(113) = 5076640.00000000
- M1066a_V%radius_1066a(114) = 5111270.00000000
- M1066a_V%radius_1066a(115) = 5145900.00000000
- M1066a_V%radius_1066a(116) = 5180530.00000000
- M1066a_V%radius_1066a(117) = 5215160.00000000
- M1066a_V%radius_1066a(118) = 5249790.00000000
- M1066a_V%radius_1066a(119) = 5284420.00000000
- M1066a_V%radius_1066a(120) = 5319060.00000000
- M1066a_V%radius_1066a(121) = 5353690.00000000
- M1066a_V%radius_1066a(122) = 5388320.00000000
- M1066a_V%radius_1066a(123) = 5422950.00000000
- M1066a_V%radius_1066a(124) = 5457580.00000000
- M1066a_V%radius_1066a(125) = 5492210.00000000
- M1066a_V%radius_1066a(126) = 5526840.00000000
- M1066a_V%radius_1066a(127) = 5561470.00000000
- M1066a_V%radius_1066a(128) = 5596110.00000000
- M1066a_V%radius_1066a(129) = 5630740.00000000
- M1066a_V%radius_1066a(130) = 5665370.00000000
- M1066a_V%radius_1066a(131) = 5700000.00000000
- M1066a_V%radius_1066a(132) = 5700000.00000000
- M1066a_V%radius_1066a(133) = 5731250.00000000
- M1066a_V%radius_1066a(134) = 5762500.00000000
- M1066a_V%radius_1066a(135) = 5793750.00000000
- M1066a_V%radius_1066a(136) = 5825000.00000000
- M1066a_V%radius_1066a(137) = 5856250.00000000
- M1066a_V%radius_1066a(138) = 5887500.00000000
- M1066a_V%radius_1066a(139) = 5918750.00000000
- M1066a_V%radius_1066a(140) = 5950000.00000000
- M1066a_V%radius_1066a(141) = 5950000.00000000
- M1066a_V%radius_1066a(142) = 5975630.00000000
- M1066a_V%radius_1066a(143) = 6001250.00000000
- M1066a_V%radius_1066a(144) = 6026880.00000000
- M1066a_V%radius_1066a(145) = 6052500.00000000
- M1066a_V%radius_1066a(146) = 6078130.00000000
- M1066a_V%radius_1066a(147) = 6103750.00000000
- M1066a_V%radius_1066a(148) = 6129380.00000000
- M1066a_V%radius_1066a(149) = 6155000.00000000
- M1066a_V%radius_1066a(150) = 6180630.00000000
- M1066a_V%radius_1066a(151) = 6206250.00000000
- M1066a_V%radius_1066a(152) = 6231880.00000000
- M1066a_V%radius_1066a(153) = 6257500.00000000
- M1066a_V%radius_1066a(154) = 6283130.00000000
- M1066a_V%radius_1066a(155) = 6308750.00000000
- M1066a_V%radius_1066a(156) = 6334380.00000000
- M1066a_V%radius_1066a(157) = 6360000.00000000
- M1066a_V%radius_1066a(158) = 6360000.00000000
- M1066a_V%radius_1066a(159) = 6365500.00000000
- M1066a_V%radius_1066a(160) = 6371000.00000000
-
- M1066a_V%density_1066a( 1) = 13.4290300000000
- M1066a_V%density_1066a( 2) = 13.4256300000000
- M1066a_V%density_1066a( 3) = 13.4191300000000
- M1066a_V%density_1066a( 4) = 13.4135300000000
- M1066a_V%density_1066a( 5) = 13.4072300000000
- M1066a_V%density_1066a( 6) = 13.4003200000000
- M1066a_V%density_1066a( 7) = 13.3929200000000
- M1066a_V%density_1066a( 8) = 13.3847100000000
- M1066a_V%density_1066a( 9) = 13.3754000000000
- M1066a_V%density_1066a( 10) = 13.3649000000000
- M1066a_V%density_1066a( 11) = 13.3527900000000
- M1066a_V%density_1066a( 12) = 13.3389800000000
- M1066a_V%density_1066a( 13) = 13.3238700000000
- M1066a_V%density_1066a( 14) = 13.3078500000000
- M1066a_V%density_1066a( 15) = 13.2914400000000
- M1066a_V%density_1066a( 16) = 13.2750300000000
- M1066a_V%density_1066a( 17) = 13.2589100000000
- M1066a_V%density_1066a( 18) = 13.2431000000000
- M1066a_V%density_1066a( 19) = 13.2275800000000
- M1066a_V%density_1066a( 20) = 13.2123600000000
- M1066a_V%density_1066a( 21) = 13.1972500000000
- M1066a_V%density_1066a( 22) = 13.1823300000000
- M1066a_V%density_1066a( 23) = 13.1675100000000
- M1066a_V%density_1066a( 24) = 13.1527800000000
- M1066a_V%density_1066a( 25) = 13.1382600000000
- M1066a_V%density_1066a( 26) = 13.1239400000000
- M1066a_V%density_1066a( 27) = 13.1095200000000
- M1066a_V%density_1066a( 28) = 13.0953900000000
- M1066a_V%density_1066a( 29) = 13.0811600000000
- M1066a_V%density_1066a( 30) = 13.0670400000000
- M1066a_V%density_1066a( 31) = 13.0525100000000
- M1066a_V%density_1066a( 32) = 13.0385800000000
- M1066a_V%density_1066a( 33) = 13.0287500000000
- M1066a_V%density_1066a( 34) = 12.1606500000000
- M1066a_V%density_1066a( 35) = 12.1169900000000
- M1066a_V%density_1066a( 36) = 12.0748300000000
- M1066a_V%density_1066a( 37) = 12.0330700000000
- M1066a_V%density_1066a( 38) = 11.9916000000000
- M1066a_V%density_1066a( 39) = 11.9507300000000
- M1066a_V%density_1066a( 40) = 11.9104600000000
- M1066a_V%density_1066a( 41) = 11.8693800000000
- M1066a_V%density_1066a( 42) = 11.8248100000000
- M1066a_V%density_1066a( 43) = 11.7753200000000
- M1066a_V%density_1066a( 44) = 11.7220400000000
- M1066a_V%density_1066a( 45) = 11.6665500000000
- M1066a_V%density_1066a( 46) = 11.6085600000000
- M1066a_V%density_1066a( 47) = 11.5469600000000
- M1066a_V%density_1066a( 48) = 11.4809600000000
- M1066a_V%density_1066a( 49) = 11.4116600000000
- M1066a_V%density_1066a( 50) = 11.3411600000000
- M1066a_V%density_1066a( 51) = 11.2705500000000
- M1066a_V%density_1066a( 52) = 11.1982400000000
- M1066a_V%density_1066a( 53) = 11.1214200000000
- M1066a_V%density_1066a( 54) = 11.0384100000000
- M1066a_V%density_1066a( 55) = 10.9511900000000
- M1066a_V%density_1066a( 56) = 10.8631600000000
- M1066a_V%density_1066a( 57) = 10.7770300000000
- M1066a_V%density_1066a( 58) = 10.6925000000000
- M1066a_V%density_1066a( 59) = 10.6076700000000
- M1066a_V%density_1066a( 60) = 10.5207300000000
- M1066a_V%density_1066a( 61) = 10.4312000000000
- M1066a_V%density_1066a( 62) = 10.3377500000000
- M1066a_V%density_1066a( 63) = 10.2396100000000
- M1066a_V%density_1066a( 64) = 10.1378600000000
- M1066a_V%density_1066a( 65) = 10.0323000000000
- M1066a_V%density_1066a( 66) = 9.91745000000000
- M1066a_V%density_1066a( 67) = 5.53205000000000
- M1066a_V%density_1066a( 68) = 5.52147000000000
- M1066a_V%density_1066a( 69) = 5.50959000000000
- M1066a_V%density_1066a( 70) = 5.49821000000000
- M1066a_V%density_1066a( 71) = 5.48673000000000
- M1066a_V%density_1066a( 72) = 5.47495000000000
- M1066a_V%density_1066a( 73) = 5.46297000000000
- M1066a_V%density_1066a( 74) = 5.45049000000000
- M1066a_V%density_1066a( 75) = 5.43741000000000
- M1066a_V%density_1066a( 76) = 5.42382000000000
- M1066a_V%density_1066a( 77) = 5.40934000000000
- M1066a_V%density_1066a( 78) = 5.39375000000000
- M1066a_V%density_1066a( 79) = 5.37717000000000
- M1066a_V%density_1066a( 80) = 5.35958000000000
- M1066a_V%density_1066a( 81) = 5.34079000000000
- M1066a_V%density_1066a( 82) = 5.32100000000000
- M1066a_V%density_1066a( 83) = 5.30031000000000
- M1066a_V%density_1066a( 84) = 5.27902000000000
- M1066a_V%density_1066a( 85) = 5.25733000000000
- M1066a_V%density_1066a( 86) = 5.23554000000000
- M1066a_V%density_1066a( 87) = 5.21375000000000
- M1066a_V%density_1066a( 88) = 5.19196000000000
- M1066a_V%density_1066a( 89) = 5.17056000000000
- M1066a_V%density_1066a( 90) = 5.14937000000000
- M1066a_V%density_1066a( 91) = 5.12827000000000
- M1066a_V%density_1066a( 92) = 5.10758000000000
- M1066a_V%density_1066a( 93) = 5.08728000000000
- M1066a_V%density_1066a( 94) = 5.06738000000000
- M1066a_V%density_1066a( 95) = 5.04769000000000
- M1066a_V%density_1066a( 96) = 5.02809000000000
- M1066a_V%density_1066a( 97) = 5.00869000000000
- M1066a_V%density_1066a( 98) = 4.98929000000000
- M1066a_V%density_1066a( 99) = 4.96968000000000
- M1066a_V%density_1066a(100) = 4.95008000000000
- M1066a_V%density_1066a(101) = 4.93048000000000
- M1066a_V%density_1066a(102) = 4.91128000000000
- M1066a_V%density_1066a(103) = 4.89257000000000
- M1066a_V%density_1066a(104) = 4.87447000000000
- M1066a_V%density_1066a(105) = 4.85716000000000
- M1066a_V%density_1066a(106) = 4.84095000000000
- M1066a_V%density_1066a(107) = 4.82554000000000
- M1066a_V%density_1066a(108) = 4.81084000000000
- M1066a_V%density_1066a(109) = 4.79683000000000
- M1066a_V%density_1066a(110) = 4.78312000000000
- M1066a_V%density_1066a(111) = 4.76951000000000
- M1066a_V%density_1066a(112) = 4.75530000000000
- M1066a_V%density_1066a(113) = 4.74008000000000
- M1066a_V%density_1066a(114) = 4.72317000000000
- M1066a_V%density_1066a(115) = 4.70426000000000
- M1066a_V%density_1066a(116) = 4.68264000000000
- M1066a_V%density_1066a(117) = 4.65863000000000
- M1066a_V%density_1066a(118) = 4.63351000000000
- M1066a_V%density_1066a(119) = 4.60859000000000
- M1066a_V%density_1066a(120) = 4.58538000000000
- M1066a_V%density_1066a(121) = 4.56536000000000
- M1066a_V%density_1066a(122) = 4.55044000000000
- M1066a_V%density_1066a(123) = 4.54072000000000
- M1066a_V%density_1066a(124) = 4.53480000000000
- M1066a_V%density_1066a(125) = 4.53478000000000
- M1066a_V%density_1066a(126) = 4.53275000000000
- M1066a_V%density_1066a(127) = 4.50893000000000
- M1066a_V%density_1066a(128) = 4.46541000000000
- M1066a_V%density_1066a(129) = 4.40098000000000
- M1066a_V%density_1066a(130) = 4.31686000000000
- M1066a_V%density_1066a(131) = 4.20553000000000
- M1066a_V%density_1066a(132) = 4.20553000000000
- M1066a_V%density_1066a(133) = 4.10272000000000
- M1066a_V%density_1066a(134) = 4.02250000000000
- M1066a_V%density_1066a(135) = 3.95789000000000
- M1066a_V%density_1066a(136) = 3.89997000000000
- M1066a_V%density_1066a(137) = 3.84675000000000
- M1066a_V%density_1066a(138) = 3.80144000000000
- M1066a_V%density_1066a(139) = 3.76072000000000
- M1066a_V%density_1066a(140) = 3.70840000000000
- M1066a_V%density_1066a(141) = 3.70840000000000
- M1066a_V%density_1066a(142) = 3.65370000000000
- M1066a_V%density_1066a(143) = 3.59640000000000
- M1066a_V%density_1066a(144) = 3.54731000000000
- M1066a_V%density_1066a(145) = 3.50511000000000
- M1066a_V%density_1066a(146) = 3.46861000000000
- M1066a_V%density_1066a(147) = 3.43851000000000
- M1066a_V%density_1066a(148) = 3.41471000000000
- M1066a_V%density_1066a(149) = 3.39751000000000
- M1066a_V%density_1066a(150) = 3.38820000000000
- M1066a_V%density_1066a(151) = 3.38200000000000
- M1066a_V%density_1066a(152) = 3.37450000000000
- M1066a_V%density_1066a(153) = 3.36710000000000
- M1066a_V%density_1066a(154) = 3.35980000000000
- M1066a_V%density_1066a(155) = 3.35259000000000
- M1066a_V%density_1066a(156) = 3.34549000000000
- M1066a_V%density_1066a(157) = 3.33828000000000
- M1066a_V%density_1066a(158) = 2.17798000000000
- M1066a_V%density_1066a(159) = 2.17766000000000
- M1066a_V%density_1066a(160) = 2.17734000000000
-
- M1066a_V%vp_1066a( 1) = 11.3383000000000
- M1066a_V%vp_1066a( 2) = 11.3374000000000
- M1066a_V%vp_1066a( 3) = 11.3347000000000
- M1066a_V%vp_1066a( 4) = 11.3301000000000
- M1066a_V%vp_1066a( 5) = 11.3237000000000
- M1066a_V%vp_1066a( 6) = 11.3155000000000
- M1066a_V%vp_1066a( 7) = 11.3056000000000
- M1066a_V%vp_1066a( 8) = 11.2940000000000
- M1066a_V%vp_1066a( 9) = 11.2810000000000
- M1066a_V%vp_1066a( 10) = 11.2666000000000
- M1066a_V%vp_1066a( 11) = 11.2512000000000
- M1066a_V%vp_1066a( 12) = 11.2349000000000
- M1066a_V%vp_1066a( 13) = 11.2181000000000
- M1066a_V%vp_1066a( 14) = 11.2010000000000
- M1066a_V%vp_1066a( 15) = 11.1840000000000
- M1066a_V%vp_1066a( 16) = 11.1672000000000
- M1066a_V%vp_1066a( 17) = 11.1508000000000
- M1066a_V%vp_1066a( 18) = 11.1351000000000
- M1066a_V%vp_1066a( 19) = 11.1201000000000
- M1066a_V%vp_1066a( 20) = 11.1059000000000
- M1066a_V%vp_1066a( 21) = 11.0924000000000
- M1066a_V%vp_1066a( 22) = 11.0798000000000
- M1066a_V%vp_1066a( 23) = 11.0678000000000
- M1066a_V%vp_1066a( 24) = 11.0564000000000
- M1066a_V%vp_1066a( 25) = 11.0455000000000
- M1066a_V%vp_1066a( 26) = 11.0350000000000
- M1066a_V%vp_1066a( 27) = 11.0248000000000
- M1066a_V%vp_1066a( 28) = 11.0149000000000
- M1066a_V%vp_1066a( 29) = 11.0051000000000
- M1066a_V%vp_1066a( 30) = 10.9953000000000
- M1066a_V%vp_1066a( 31) = 10.9857000000000
- M1066a_V%vp_1066a( 32) = 10.9756000000000
- M1066a_V%vp_1066a( 33) = 10.9687000000000
- M1066a_V%vp_1066a( 34) = 10.4140000000000
- M1066a_V%vp_1066a( 35) = 10.3518000000000
- M1066a_V%vp_1066a( 36) = 10.2922000000000
- M1066a_V%vp_1066a( 37) = 10.2351000000000
- M1066a_V%vp_1066a( 38) = 10.1808000000000
- M1066a_V%vp_1066a( 39) = 10.1297000000000
- M1066a_V%vp_1066a( 40) = 10.0788000000000
- M1066a_V%vp_1066a( 41) = 10.0284000000000
- M1066a_V%vp_1066a( 42) = 9.97880000000000
- M1066a_V%vp_1066a( 43) = 9.93070000000000
- M1066a_V%vp_1066a( 44) = 9.88360000000000
- M1066a_V%vp_1066a( 45) = 9.83530000000000
- M1066a_V%vp_1066a( 46) = 9.78250000000000
- M1066a_V%vp_1066a( 47) = 9.72110000000000
- M1066a_V%vp_1066a( 48) = 9.65210000000000
- M1066a_V%vp_1066a( 49) = 9.58060000000000
- M1066a_V%vp_1066a( 50) = 9.51150000000000
- M1066a_V%vp_1066a( 51) = 9.44650000000000
- M1066a_V%vp_1066a( 52) = 9.38280000000000
- M1066a_V%vp_1066a( 53) = 9.31660000000000
- M1066a_V%vp_1066a( 54) = 9.24420000000000
- M1066a_V%vp_1066a( 55) = 9.16580000000000
- M1066a_V%vp_1066a( 56) = 9.08330000000000
- M1066a_V%vp_1066a( 57) = 8.99870000000000
- M1066a_V%vp_1066a( 58) = 8.91160000000000
- M1066a_V%vp_1066a( 59) = 8.82010000000000
- M1066a_V%vp_1066a( 60) = 8.72230000000000
- M1066a_V%vp_1066a( 61) = 8.61710000000000
- M1066a_V%vp_1066a( 62) = 8.50300000000000
- M1066a_V%vp_1066a( 63) = 8.38070000000000
- M1066a_V%vp_1066a( 64) = 8.25560000000000
- M1066a_V%vp_1066a( 65) = 8.13180000000000
- M1066a_V%vp_1066a( 66) = 8.01120000000000
- M1066a_V%vp_1066a( 67) = 13.7172000000000
- M1066a_V%vp_1066a( 68) = 13.7134000000000
- M1066a_V%vp_1066a( 69) = 13.7089000000000
- M1066a_V%vp_1066a( 70) = 13.6806000000000
- M1066a_V%vp_1066a( 71) = 13.6517000000000
- M1066a_V%vp_1066a( 72) = 13.6251000000000
- M1066a_V%vp_1066a( 73) = 13.5916000000000
- M1066a_V%vp_1066a( 74) = 13.5564000000000
- M1066a_V%vp_1066a( 75) = 13.5165000000000
- M1066a_V%vp_1066a( 76) = 13.4725000000000
- M1066a_V%vp_1066a( 77) = 13.4248000000000
- M1066a_V%vp_1066a( 78) = 13.3742000000000
- M1066a_V%vp_1066a( 79) = 13.3216000000000
- M1066a_V%vp_1066a( 80) = 13.2679000000000
- M1066a_V%vp_1066a( 81) = 13.2142000000000
- M1066a_V%vp_1066a( 82) = 13.1619000000000
- M1066a_V%vp_1066a( 83) = 13.1114000000000
- M1066a_V%vp_1066a( 84) = 13.0631000000000
- M1066a_V%vp_1066a( 85) = 13.0174000000000
- M1066a_V%vp_1066a( 86) = 12.9745000000000
- M1066a_V%vp_1066a( 87) = 12.9346000000000
- M1066a_V%vp_1066a( 88) = 12.8977000000000
- M1066a_V%vp_1066a( 89) = 12.8635000000000
- M1066a_V%vp_1066a( 90) = 12.8318000000000
- M1066a_V%vp_1066a( 91) = 12.8022000000000
- M1066a_V%vp_1066a( 92) = 12.7739000000000
- M1066a_V%vp_1066a( 93) = 12.7463000000000
- M1066a_V%vp_1066a( 94) = 12.7186000000000
- M1066a_V%vp_1066a( 95) = 12.6903000000000
- M1066a_V%vp_1066a( 96) = 12.6610000000000
- M1066a_V%vp_1066a( 97) = 12.6302000000000
- M1066a_V%vp_1066a( 98) = 12.5978000000000
- M1066a_V%vp_1066a( 99) = 12.5637000000000
- M1066a_V%vp_1066a(100) = 12.5276000000000
- M1066a_V%vp_1066a(101) = 12.4893000000000
- M1066a_V%vp_1066a(102) = 12.4485000000000
- M1066a_V%vp_1066a(103) = 12.4052000000000
- M1066a_V%vp_1066a(104) = 12.3592000000000
- M1066a_V%vp_1066a(105) = 12.3105000000000
- M1066a_V%vp_1066a(106) = 12.2596000000000
- M1066a_V%vp_1066a(107) = 12.2072000000000
- M1066a_V%vp_1066a(108) = 12.1538000000000
- M1066a_V%vp_1066a(109) = 12.0998000000000
- M1066a_V%vp_1066a(110) = 12.0458000000000
- M1066a_V%vp_1066a(111) = 11.9920000000000
- M1066a_V%vp_1066a(112) = 11.9373000000000
- M1066a_V%vp_1066a(113) = 11.8804000000000
- M1066a_V%vp_1066a(114) = 11.8200000000000
- M1066a_V%vp_1066a(115) = 11.7554000000000
- M1066a_V%vp_1066a(116) = 11.6844000000000
- M1066a_V%vp_1066a(117) = 11.6079000000000
- M1066a_V%vp_1066a(118) = 11.5308000000000
- M1066a_V%vp_1066a(119) = 11.4579000000000
- M1066a_V%vp_1066a(120) = 11.3935000000000
- M1066a_V%vp_1066a(121) = 11.3418000000000
- M1066a_V%vp_1066a(122) = 11.3085000000000
- M1066a_V%vp_1066a(123) = 11.2938000000000
- M1066a_V%vp_1066a(124) = 11.2915000000000
- M1066a_V%vp_1066a(125) = 11.3049000000000
- M1066a_V%vp_1066a(126) = 11.3123000000000
- M1066a_V%vp_1066a(127) = 11.2643000000000
- M1066a_V%vp_1066a(128) = 11.1635000000000
- M1066a_V%vp_1066a(129) = 11.0063000000000
- M1066a_V%vp_1066a(130) = 10.7959000000000
- M1066a_V%vp_1066a(131) = 10.5143000000000
- M1066a_V%vp_1066a(132) = 10.5143000000000
- M1066a_V%vp_1066a(133) = 10.2513000000000
- M1066a_V%vp_1066a(134) = 10.0402000000000
- M1066a_V%vp_1066a(135) = 9.86480000000000
- M1066a_V%vp_1066a(136) = 9.70860000000000
- M1066a_V%vp_1066a(137) = 9.56810000000000
- M1066a_V%vp_1066a(138) = 9.45120000000000
- M1066a_V%vp_1066a(139) = 9.35100000000000
- M1066a_V%vp_1066a(140) = 9.22830000000000
- M1066a_V%vp_1066a(141) = 9.22830000000000
- M1066a_V%vp_1066a(142) = 9.10870000000000
- M1066a_V%vp_1066a(143) = 8.98230000000000
- M1066a_V%vp_1066a(144) = 8.85920000000000
- M1066a_V%vp_1066a(145) = 8.73860000000000
- M1066a_V%vp_1066a(146) = 8.61930000000000
- M1066a_V%vp_1066a(147) = 8.50180000000000
- M1066a_V%vp_1066a(148) = 8.38710000000000
- M1066a_V%vp_1066a(149) = 8.27360000000000
- M1066a_V%vp_1066a(150) = 8.15850000000000
- M1066a_V%vp_1066a(151) = 8.05400000000000
- M1066a_V%vp_1066a(152) = 7.96520000000000
- M1066a_V%vp_1066a(153) = 7.87340000000000
- M1066a_V%vp_1066a(154) = 7.79720000000000
- M1066a_V%vp_1066a(155) = 7.73910000000000
- M1066a_V%vp_1066a(156) = 7.71340000000000
- M1066a_V%vp_1066a(157) = 7.70460000000000
- M1066a_V%vp_1066a(158) = 4.70220000000000
- M1066a_V%vp_1066a(159) = 4.70010000000000
- M1066a_V%vp_1066a(160) = 4.69790000000000
-
- M1066a_V%vs_1066a( 1) = 3.62980000000000
- M1066a_V%vs_1066a( 2) = 3.62970000000000
- M1066a_V%vs_1066a( 3) = 3.62940000000000
- M1066a_V%vs_1066a( 4) = 3.62880000000000
- M1066a_V%vs_1066a( 5) = 3.62810000000000
- M1066a_V%vs_1066a( 6) = 3.62710000000000
- M1066a_V%vs_1066a( 7) = 3.62590000000000
- M1066a_V%vs_1066a( 8) = 3.62440000000000
- M1066a_V%vs_1066a( 9) = 3.62280000000000
- M1066a_V%vs_1066a( 10) = 3.62090000000000
- M1066a_V%vs_1066a( 11) = 3.61870000000000
- M1066a_V%vs_1066a( 12) = 3.61630000000000
- M1066a_V%vs_1066a( 13) = 3.61370000000000
- M1066a_V%vs_1066a( 14) = 3.61080000000000
- M1066a_V%vs_1066a( 15) = 3.60760000000000
- M1066a_V%vs_1066a( 16) = 3.60420000000000
- M1066a_V%vs_1066a( 17) = 3.60040000000000
- M1066a_V%vs_1066a( 18) = 3.59650000000000
- M1066a_V%vs_1066a( 19) = 3.59220000000000
- M1066a_V%vs_1066a( 20) = 3.58760000000000
- M1066a_V%vs_1066a( 21) = 3.58280000000000
- M1066a_V%vs_1066a( 22) = 3.57770000000000
- M1066a_V%vs_1066a( 23) = 3.57240000000000
- M1066a_V%vs_1066a( 24) = 3.56680000000000
- M1066a_V%vs_1066a( 25) = 3.56100000000000
- M1066a_V%vs_1066a( 26) = 3.55510000000000
- M1066a_V%vs_1066a( 27) = 3.54900000000000
- M1066a_V%vs_1066a( 28) = 3.54280000000000
- M1066a_V%vs_1066a( 29) = 3.53650000000000
- M1066a_V%vs_1066a( 30) = 3.53010000000000
- M1066a_V%vs_1066a( 31) = 3.52380000000000
- M1066a_V%vs_1066a( 32) = 3.51720000000000
- M1066a_V%vs_1066a( 33) = 3.51180000000000
- M1066a_V%vs_1066a( 34) = 0.000000000000000
- M1066a_V%vs_1066a( 35) = 0.000000000000000
- M1066a_V%vs_1066a( 36) = 0.000000000000000
- M1066a_V%vs_1066a( 37) = 0.000000000000000
- M1066a_V%vs_1066a( 38) = 0.000000000000000
- M1066a_V%vs_1066a( 39) = 0.000000000000000
- M1066a_V%vs_1066a( 40) = 0.000000000000000
- M1066a_V%vs_1066a( 41) = 0.000000000000000
- M1066a_V%vs_1066a( 42) = 0.000000000000000
- M1066a_V%vs_1066a( 43) = 0.000000000000000
- M1066a_V%vs_1066a( 44) = 0.000000000000000
- M1066a_V%vs_1066a( 45) = 0.000000000000000
- M1066a_V%vs_1066a( 46) = 0.000000000000000
- M1066a_V%vs_1066a( 47) = 0.000000000000000
- M1066a_V%vs_1066a( 48) = 0.000000000000000
- M1066a_V%vs_1066a( 49) = 0.000000000000000
- M1066a_V%vs_1066a( 50) = 0.000000000000000
- M1066a_V%vs_1066a( 51) = 0.000000000000000
- M1066a_V%vs_1066a( 52) = 0.000000000000000
- M1066a_V%vs_1066a( 53) = 0.000000000000000
- M1066a_V%vs_1066a( 54) = 0.000000000000000
- M1066a_V%vs_1066a( 55) = 0.000000000000000
- M1066a_V%vs_1066a( 56) = 0.000000000000000
- M1066a_V%vs_1066a( 57) = 0.000000000000000
- M1066a_V%vs_1066a( 58) = 0.000000000000000
- M1066a_V%vs_1066a( 59) = 0.000000000000000
- M1066a_V%vs_1066a( 60) = 0.000000000000000
- M1066a_V%vs_1066a( 61) = 0.000000000000000
- M1066a_V%vs_1066a( 62) = 0.000000000000000
- M1066a_V%vs_1066a( 63) = 0.000000000000000
- M1066a_V%vs_1066a( 64) = 0.000000000000000
- M1066a_V%vs_1066a( 65) = 0.000000000000000
- M1066a_V%vs_1066a( 66) = 0.000000000000000
- M1066a_V%vs_1066a( 67) = 7.24980000000000
- M1066a_V%vs_1066a( 68) = 7.23760000000000
- M1066a_V%vs_1066a( 69) = 7.22390000000000
- M1066a_V%vs_1066a( 70) = 7.21000000000000
- M1066a_V%vs_1066a( 71) = 7.19640000000000
- M1066a_V%vs_1066a( 72) = 7.18300000000000
- M1066a_V%vs_1066a( 73) = 7.16990000000000
- M1066a_V%vs_1066a( 74) = 7.15710000000000
- M1066a_V%vs_1066a( 75) = 7.14450000000000
- M1066a_V%vs_1066a( 76) = 7.13200000000000
- M1066a_V%vs_1066a( 77) = 7.11960000000000
- M1066a_V%vs_1066a( 78) = 7.10740000000000
- M1066a_V%vs_1066a( 79) = 7.09530000000000
- M1066a_V%vs_1066a( 80) = 7.08320000000000
- M1066a_V%vs_1066a( 81) = 7.07120000000000
- M1066a_V%vs_1066a( 82) = 7.05920000000000
- M1066a_V%vs_1066a( 83) = 7.04710000000000
- M1066a_V%vs_1066a( 84) = 7.03470000000000
- M1066a_V%vs_1066a( 85) = 7.02190000000000
- M1066a_V%vs_1066a( 86) = 7.00860000000000
- M1066a_V%vs_1066a( 87) = 6.99470000000000
- M1066a_V%vs_1066a( 88) = 6.98030000000000
- M1066a_V%vs_1066a( 89) = 6.96510000000000
- M1066a_V%vs_1066a( 90) = 6.94930000000000
- M1066a_V%vs_1066a( 91) = 6.93290000000000
- M1066a_V%vs_1066a( 92) = 6.91620000000000
- M1066a_V%vs_1066a( 93) = 6.89910000000000
- M1066a_V%vs_1066a( 94) = 6.88200000000000
- M1066a_V%vs_1066a( 95) = 6.86520000000000
- M1066a_V%vs_1066a( 96) = 6.84900000000000
- M1066a_V%vs_1066a( 97) = 6.83340000000000
- M1066a_V%vs_1066a( 98) = 6.81820000000000
- M1066a_V%vs_1066a( 99) = 6.80360000000000
- M1066a_V%vs_1066a(100) = 6.78910000000000
- M1066a_V%vs_1066a(101) = 6.77440000000000
- M1066a_V%vs_1066a(102) = 6.75890000000000
- M1066a_V%vs_1066a(103) = 6.74270000000000
- M1066a_V%vs_1066a(104) = 6.72550000000000
- M1066a_V%vs_1066a(105) = 6.70730000000000
- M1066a_V%vs_1066a(106) = 6.68810000000000
- M1066a_V%vs_1066a(107) = 6.66840000000000
- M1066a_V%vs_1066a(108) = 6.64850000000000
- M1066a_V%vs_1066a(109) = 6.62880000000000
- M1066a_V%vs_1066a(110) = 6.60950000000000
- M1066a_V%vs_1066a(111) = 6.59110000000000
- M1066a_V%vs_1066a(112) = 6.57310000000000
- M1066a_V%vs_1066a(113) = 6.55480000000000
- M1066a_V%vs_1066a(114) = 6.53510000000000
- M1066a_V%vs_1066a(115) = 6.51330000000000
- M1066a_V%vs_1066a(116) = 6.48810000000000
- M1066a_V%vs_1066a(117) = 6.45940000000000
- M1066a_V%vs_1066a(118) = 6.42860000000000
- M1066a_V%vs_1066a(119) = 6.39760000000000
- M1066a_V%vs_1066a(120) = 6.36840000000000
- M1066a_V%vs_1066a(121) = 6.34280000000000
- M1066a_V%vs_1066a(122) = 6.32350000000000
- M1066a_V%vs_1066a(123) = 6.31140000000000
- M1066a_V%vs_1066a(124) = 6.30410000000000
- M1066a_V%vs_1066a(125) = 6.30520000000000
- M1066a_V%vs_1066a(126) = 6.30210000000000
- M1066a_V%vs_1066a(127) = 6.26430000000000
- M1066a_V%vs_1066a(128) = 6.19470000000000
- M1066a_V%vs_1066a(129) = 6.09120000000000
- M1066a_V%vs_1066a(130) = 5.95550000000000
- M1066a_V%vs_1066a(131) = 5.77550000000000
- M1066a_V%vs_1066a(132) = 5.77550000000000
- M1066a_V%vs_1066a(133) = 5.60830000000000
- M1066a_V%vs_1066a(134) = 5.47520000000000
- M1066a_V%vs_1066a(135) = 5.36530000000000
- M1066a_V%vs_1066a(136) = 5.26650000000000
- M1066a_V%vs_1066a(137) = 5.17620000000000
- M1066a_V%vs_1066a(138) = 5.09960000000000
- M1066a_V%vs_1066a(139) = 5.03220000000000
- M1066a_V%vs_1066a(140) = 4.94880000000000
- M1066a_V%vs_1066a(141) = 4.94880000000000
- M1066a_V%vs_1066a(142) = 4.86670000000000
- M1066a_V%vs_1066a(143) = 4.78060000000000
- M1066a_V%vs_1066a(144) = 4.69950000000000
- M1066a_V%vs_1066a(145) = 4.62110000000000
- M1066a_V%vs_1066a(146) = 4.54790000000000
- M1066a_V%vs_1066a(147) = 4.48820000000000
- M1066a_V%vs_1066a(148) = 4.44210000000000
- M1066a_V%vs_1066a(149) = 4.40840000000000
- M1066a_V%vs_1066a(150) = 4.38740000000000
- M1066a_V%vs_1066a(151) = 4.37950000000000
- M1066a_V%vs_1066a(152) = 4.39040000000000
- M1066a_V%vs_1066a(153) = 4.43310000000000
- M1066a_V%vs_1066a(154) = 4.48300000000000
- M1066a_V%vs_1066a(155) = 4.53890000000000
- M1066a_V%vs_1066a(156) = 4.60400000000000
- M1066a_V%vs_1066a(157) = 4.64870000000000
- M1066a_V%vs_1066a(158) = 2.58060000000000
- M1066a_V%vs_1066a(159) = 2.58140000000000
- M1066a_V%vs_1066a(160) = 2.58220000000000
-
- if (SUPPRESS_CRUSTAL_MESH) then
- M1066a_V%vp_1066a(158:160) = M1066a_V%vp_1066a(157)
- M1066a_V%vs_1066a(158:160) = M1066a_V%vs_1066a(157)
- M1066a_V%density_1066a(158:160) = M1066a_V%density_1066a(157)
- endif
-
- M1066a_V%Qkappa_1066a( 1) = 156900.000000000
- M1066a_V%Qkappa_1066a( 2) = 156900.000000000
- M1066a_V%Qkappa_1066a( 3) = 156900.000000000
- M1066a_V%Qkappa_1066a( 4) = 156900.000000000
- M1066a_V%Qkappa_1066a( 5) = 156900.000000000
- M1066a_V%Qkappa_1066a( 6) = 156900.000000000
- M1066a_V%Qkappa_1066a( 7) = 156900.000000000
- M1066a_V%Qkappa_1066a( 8) = 156900.000000000
- M1066a_V%Qkappa_1066a( 9) = 156900.000000000
- M1066a_V%Qkappa_1066a( 10) = 156900.000000000
- M1066a_V%Qkappa_1066a( 11) = 156900.000000000
- M1066a_V%Qkappa_1066a( 12) = 156900.000000000
- M1066a_V%Qkappa_1066a( 13) = 156900.000000000
- M1066a_V%Qkappa_1066a( 14) = 156900.000000000
- M1066a_V%Qkappa_1066a( 15) = 156900.000000000
- M1066a_V%Qkappa_1066a( 16) = 156900.000000000
- M1066a_V%Qkappa_1066a( 17) = 156900.000000000
- M1066a_V%Qkappa_1066a( 18) = 156900.000000000
- M1066a_V%Qkappa_1066a( 19) = 156900.000000000
- M1066a_V%Qkappa_1066a( 20) = 156900.000000000
- M1066a_V%Qkappa_1066a( 21) = 156900.000000000
- M1066a_V%Qkappa_1066a( 22) = 156900.000000000
- M1066a_V%Qkappa_1066a( 23) = 156900.000000000
- M1066a_V%Qkappa_1066a( 24) = 156900.000000000
- M1066a_V%Qkappa_1066a( 25) = 156900.000000000
- M1066a_V%Qkappa_1066a( 26) = 156900.000000000
- M1066a_V%Qkappa_1066a( 27) = 156900.000000000
- M1066a_V%Qkappa_1066a( 28) = 156900.000000000
- M1066a_V%Qkappa_1066a( 29) = 156900.000000000
- M1066a_V%Qkappa_1066a( 30) = 156900.000000000
- M1066a_V%Qkappa_1066a( 31) = 156900.000000000
- M1066a_V%Qkappa_1066a( 32) = 156900.000000000
- M1066a_V%Qkappa_1066a( 33) = 156900.000000000
- M1066a_V%Qkappa_1066a( 34) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 35) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 36) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 37) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 38) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 39) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 40) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 41) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 42) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 43) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 44) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 45) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 46) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 47) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 48) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 49) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 50) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 51) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 52) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 53) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 54) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 55) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 56) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 57) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 58) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 59) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 60) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 61) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 62) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 63) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 64) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 65) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 66) = 0.000000000000000
- M1066a_V%Qkappa_1066a( 67) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 68) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 69) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 70) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 71) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 72) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 73) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 74) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 75) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 76) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 77) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 78) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 79) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 80) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 81) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 82) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 83) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 84) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 85) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 86) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 87) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 88) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 89) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 90) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 91) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 92) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 93) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 94) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 95) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 96) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 97) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 98) = 16600.0000000000
- M1066a_V%Qkappa_1066a( 99) = 16600.0000000000
- M1066a_V%Qkappa_1066a(100) = 16600.0000000000
- M1066a_V%Qkappa_1066a(101) = 16600.0000000000
- M1066a_V%Qkappa_1066a(102) = 16600.0000000000
- M1066a_V%Qkappa_1066a(103) = 16600.0000000000
- M1066a_V%Qkappa_1066a(104) = 16600.0000000000
- M1066a_V%Qkappa_1066a(105) = 16600.0000000000
- M1066a_V%Qkappa_1066a(106) = 16600.0000000000
- M1066a_V%Qkappa_1066a(107) = 16600.0000000000
- M1066a_V%Qkappa_1066a(108) = 16600.0000000000
- M1066a_V%Qkappa_1066a(109) = 16600.0000000000
- M1066a_V%Qkappa_1066a(110) = 16600.0000000000
- M1066a_V%Qkappa_1066a(111) = 16600.0000000000
- M1066a_V%Qkappa_1066a(112) = 16600.0000000000
- M1066a_V%Qkappa_1066a(113) = 16600.0000000000
- M1066a_V%Qkappa_1066a(114) = 16600.0000000000
- M1066a_V%Qkappa_1066a(115) = 16600.0000000000
- M1066a_V%Qkappa_1066a(116) = 16600.0000000000
- M1066a_V%Qkappa_1066a(117) = 16600.0000000000
- M1066a_V%Qkappa_1066a(118) = 16600.0000000000
- M1066a_V%Qkappa_1066a(119) = 16600.0000000000
- M1066a_V%Qkappa_1066a(120) = 16600.0000000000
- M1066a_V%Qkappa_1066a(121) = 16600.0000000000
- M1066a_V%Qkappa_1066a(122) = 16600.0000000000
- M1066a_V%Qkappa_1066a(123) = 16600.0000000000
- M1066a_V%Qkappa_1066a(124) = 16600.0000000000
- M1066a_V%Qkappa_1066a(125) = 16600.0000000000
- M1066a_V%Qkappa_1066a(126) = 16600.0000000000
- M1066a_V%Qkappa_1066a(127) = 16600.0000000000
- M1066a_V%Qkappa_1066a(128) = 16600.0000000000
- M1066a_V%Qkappa_1066a(129) = 16600.0000000000
- M1066a_V%Qkappa_1066a(130) = 16600.0000000000
- M1066a_V%Qkappa_1066a(131) = 16600.0000000000
- M1066a_V%Qkappa_1066a(132) = 13840.0000000000
- M1066a_V%Qkappa_1066a(133) = 13840.0000000000
- M1066a_V%Qkappa_1066a(134) = 13840.0000000000
- M1066a_V%Qkappa_1066a(135) = 13840.0000000000
- M1066a_V%Qkappa_1066a(136) = 13840.0000000000
- M1066a_V%Qkappa_1066a(137) = 13840.0000000000
- M1066a_V%Qkappa_1066a(138) = 13840.0000000000
- M1066a_V%Qkappa_1066a(139) = 13840.0000000000
- M1066a_V%Qkappa_1066a(140) = 13840.0000000000
- M1066a_V%Qkappa_1066a(141) = 5893.00000000000
- M1066a_V%Qkappa_1066a(142) = 5893.00000000000
- M1066a_V%Qkappa_1066a(143) = 5893.00000000000
- M1066a_V%Qkappa_1066a(144) = 5893.00000000000
- M1066a_V%Qkappa_1066a(145) = 5893.00000000000
- M1066a_V%Qkappa_1066a(146) = 5893.00000000000
- M1066a_V%Qkappa_1066a(147) = 5893.00000000000
- M1066a_V%Qkappa_1066a(148) = 5893.00000000000
- M1066a_V%Qkappa_1066a(149) = 5893.00000000000
- M1066a_V%Qkappa_1066a(150) = 5893.00000000000
- M1066a_V%Qkappa_1066a(151) = 5893.00000000000
- M1066a_V%Qkappa_1066a(152) = 5893.00000000000
- M1066a_V%Qkappa_1066a(153) = 5893.00000000000
- M1066a_V%Qkappa_1066a(154) = 5893.00000000000
- M1066a_V%Qkappa_1066a(155) = 5893.00000000000
- M1066a_V%Qkappa_1066a(156) = 5893.00000000000
- M1066a_V%Qkappa_1066a(157) = 5893.00000000000
- M1066a_V%Qkappa_1066a(158) = 5893.00000000000
- M1066a_V%Qkappa_1066a(159) = 5893.00000000000
- M1066a_V%Qkappa_1066a(160) = 5893.00000000000
-
- M1066a_V%Qmu_1066a( 1) = 3138.00000000000
- M1066a_V%Qmu_1066a( 2) = 3138.00000000000
- M1066a_V%Qmu_1066a( 3) = 3138.00000000000
- M1066a_V%Qmu_1066a( 4) = 3138.00000000000
- M1066a_V%Qmu_1066a( 5) = 3138.00000000000
- M1066a_V%Qmu_1066a( 6) = 3138.00000000000
- M1066a_V%Qmu_1066a( 7) = 3138.00000000000
- M1066a_V%Qmu_1066a( 8) = 3138.00000000000
- M1066a_V%Qmu_1066a( 9) = 3138.00000000000
- M1066a_V%Qmu_1066a( 10) = 3138.00000000000
- M1066a_V%Qmu_1066a( 11) = 3138.00000000000
- M1066a_V%Qmu_1066a( 12) = 3138.00000000000
- M1066a_V%Qmu_1066a( 13) = 3138.00000000000
- M1066a_V%Qmu_1066a( 14) = 3138.00000000000
- M1066a_V%Qmu_1066a( 15) = 3138.00000000000
- M1066a_V%Qmu_1066a( 16) = 3138.00000000000
- M1066a_V%Qmu_1066a( 17) = 3138.00000000000
- M1066a_V%Qmu_1066a( 18) = 3138.00000000000
- M1066a_V%Qmu_1066a( 19) = 3138.00000000000
- M1066a_V%Qmu_1066a( 20) = 3138.00000000000
- M1066a_V%Qmu_1066a( 21) = 3138.00000000000
- M1066a_V%Qmu_1066a( 22) = 3138.00000000000
- M1066a_V%Qmu_1066a( 23) = 3138.00000000000
- M1066a_V%Qmu_1066a( 24) = 3138.00000000000
- M1066a_V%Qmu_1066a( 25) = 3138.00000000000
- M1066a_V%Qmu_1066a( 26) = 3138.00000000000
- M1066a_V%Qmu_1066a( 27) = 3138.00000000000
- M1066a_V%Qmu_1066a( 28) = 3138.00000000000
- M1066a_V%Qmu_1066a( 29) = 3138.00000000000
- M1066a_V%Qmu_1066a( 30) = 3138.00000000000
- M1066a_V%Qmu_1066a( 31) = 3138.00000000000
- M1066a_V%Qmu_1066a( 32) = 3138.00000000000
- M1066a_V%Qmu_1066a( 33) = 3138.00000000000
- M1066a_V%Qmu_1066a( 34) = 0.000000000000000
- M1066a_V%Qmu_1066a( 35) = 0.000000000000000
- M1066a_V%Qmu_1066a( 36) = 0.000000000000000
- M1066a_V%Qmu_1066a( 37) = 0.000000000000000
- M1066a_V%Qmu_1066a( 38) = 0.000000000000000
- M1066a_V%Qmu_1066a( 39) = 0.000000000000000
- M1066a_V%Qmu_1066a( 40) = 0.000000000000000
- M1066a_V%Qmu_1066a( 41) = 0.000000000000000
- M1066a_V%Qmu_1066a( 42) = 0.000000000000000
- M1066a_V%Qmu_1066a( 43) = 0.000000000000000
- M1066a_V%Qmu_1066a( 44) = 0.000000000000000
- M1066a_V%Qmu_1066a( 45) = 0.000000000000000
- M1066a_V%Qmu_1066a( 46) = 0.000000000000000
- M1066a_V%Qmu_1066a( 47) = 0.000000000000000
- M1066a_V%Qmu_1066a( 48) = 0.000000000000000
- M1066a_V%Qmu_1066a( 49) = 0.000000000000000
- M1066a_V%Qmu_1066a( 50) = 0.000000000000000
- M1066a_V%Qmu_1066a( 51) = 0.000000000000000
- M1066a_V%Qmu_1066a( 52) = 0.000000000000000
- M1066a_V%Qmu_1066a( 53) = 0.000000000000000
- M1066a_V%Qmu_1066a( 54) = 0.000000000000000
- M1066a_V%Qmu_1066a( 55) = 0.000000000000000
- M1066a_V%Qmu_1066a( 56) = 0.000000000000000
- M1066a_V%Qmu_1066a( 57) = 0.000000000000000
- M1066a_V%Qmu_1066a( 58) = 0.000000000000000
- M1066a_V%Qmu_1066a( 59) = 0.000000000000000
- M1066a_V%Qmu_1066a( 60) = 0.000000000000000
- M1066a_V%Qmu_1066a( 61) = 0.000000000000000
- M1066a_V%Qmu_1066a( 62) = 0.000000000000000
- M1066a_V%Qmu_1066a( 63) = 0.000000000000000
- M1066a_V%Qmu_1066a( 64) = 0.000000000000000
- M1066a_V%Qmu_1066a( 65) = 0.000000000000000
- M1066a_V%Qmu_1066a( 66) = 0.000000000000000
- M1066a_V%Qmu_1066a( 67) = 332.000000000000
- M1066a_V%Qmu_1066a( 68) = 332.000000000000
- M1066a_V%Qmu_1066a( 69) = 332.000000000000
- M1066a_V%Qmu_1066a( 70) = 332.000000000000
- M1066a_V%Qmu_1066a( 71) = 332.000000000000
- M1066a_V%Qmu_1066a( 72) = 332.000000000000
- M1066a_V%Qmu_1066a( 73) = 332.000000000000
- M1066a_V%Qmu_1066a( 74) = 332.000000000000
- M1066a_V%Qmu_1066a( 75) = 332.000000000000
- M1066a_V%Qmu_1066a( 76) = 332.000000000000
- M1066a_V%Qmu_1066a( 77) = 332.000000000000
- M1066a_V%Qmu_1066a( 78) = 332.000000000000
- M1066a_V%Qmu_1066a( 79) = 332.000000000000
- M1066a_V%Qmu_1066a( 80) = 332.000000000000
- M1066a_V%Qmu_1066a( 81) = 332.000000000000
- M1066a_V%Qmu_1066a( 82) = 332.000000000000
- M1066a_V%Qmu_1066a( 83) = 332.000000000000
- M1066a_V%Qmu_1066a( 84) = 332.000000000000
- M1066a_V%Qmu_1066a( 85) = 332.000000000000
- M1066a_V%Qmu_1066a( 86) = 332.000000000000
- M1066a_V%Qmu_1066a( 87) = 332.000000000000
- M1066a_V%Qmu_1066a( 88) = 332.000000000000
- M1066a_V%Qmu_1066a( 89) = 332.000000000000
- M1066a_V%Qmu_1066a( 90) = 332.000000000000
- M1066a_V%Qmu_1066a( 91) = 332.000000000000
- M1066a_V%Qmu_1066a( 92) = 332.000000000000
- M1066a_V%Qmu_1066a( 93) = 332.000000000000
- M1066a_V%Qmu_1066a( 94) = 332.000000000000
- M1066a_V%Qmu_1066a( 95) = 332.000000000000
- M1066a_V%Qmu_1066a( 96) = 332.000000000000
- M1066a_V%Qmu_1066a( 97) = 332.000000000000
- M1066a_V%Qmu_1066a( 98) = 332.000000000000
- M1066a_V%Qmu_1066a( 99) = 332.000000000000
- M1066a_V%Qmu_1066a(100) = 332.000000000000
- M1066a_V%Qmu_1066a(101) = 332.000000000000
- M1066a_V%Qmu_1066a(102) = 332.000000000000
- M1066a_V%Qmu_1066a(103) = 332.000000000000
- M1066a_V%Qmu_1066a(104) = 332.000000000000
- M1066a_V%Qmu_1066a(105) = 332.000000000000
- M1066a_V%Qmu_1066a(106) = 332.000000000000
- M1066a_V%Qmu_1066a(107) = 332.000000000000
- M1066a_V%Qmu_1066a(108) = 332.000000000000
- M1066a_V%Qmu_1066a(109) = 332.000000000000
- M1066a_V%Qmu_1066a(110) = 332.000000000000
- M1066a_V%Qmu_1066a(111) = 332.000000000000
- M1066a_V%Qmu_1066a(112) = 332.000000000000
- M1066a_V%Qmu_1066a(113) = 332.000000000000
- M1066a_V%Qmu_1066a(114) = 332.000000000000
- M1066a_V%Qmu_1066a(115) = 332.000000000000
- M1066a_V%Qmu_1066a(116) = 332.000000000000
- M1066a_V%Qmu_1066a(117) = 332.000000000000
- M1066a_V%Qmu_1066a(118) = 332.000000000000
- M1066a_V%Qmu_1066a(119) = 332.000000000000
- M1066a_V%Qmu_1066a(120) = 332.000000000000
- M1066a_V%Qmu_1066a(121) = 332.000000000000
- M1066a_V%Qmu_1066a(122) = 332.000000000000
- M1066a_V%Qmu_1066a(123) = 332.000000000000
- M1066a_V%Qmu_1066a(124) = 332.000000000000
- M1066a_V%Qmu_1066a(125) = 332.000000000000
- M1066a_V%Qmu_1066a(126) = 332.000000000000
- M1066a_V%Qmu_1066a(127) = 332.000000000000
- M1066a_V%Qmu_1066a(128) = 332.000000000000
- M1066a_V%Qmu_1066a(129) = 332.000000000000
- M1066a_V%Qmu_1066a(130) = 332.000000000000
- M1066a_V%Qmu_1066a(131) = 332.000000000000
- M1066a_V%Qmu_1066a(132) = 276.800000000000
- M1066a_V%Qmu_1066a(133) = 276.800000000000
- M1066a_V%Qmu_1066a(134) = 276.800000000000
- M1066a_V%Qmu_1066a(135) = 276.800000000000
- M1066a_V%Qmu_1066a(136) = 276.800000000000
- M1066a_V%Qmu_1066a(137) = 276.800000000000
- M1066a_V%Qmu_1066a(138) = 276.800000000000
- M1066a_V%Qmu_1066a(139) = 276.800000000000
- M1066a_V%Qmu_1066a(140) = 276.800000000000
- M1066a_V%Qmu_1066a(141) = 117.900000000000
- M1066a_V%Qmu_1066a(142) = 117.900000000000
- M1066a_V%Qmu_1066a(143) = 117.900000000000
- M1066a_V%Qmu_1066a(144) = 117.900000000000
- M1066a_V%Qmu_1066a(145) = 117.900000000000
- M1066a_V%Qmu_1066a(146) = 117.900000000000
- M1066a_V%Qmu_1066a(147) = 117.900000000000
- M1066a_V%Qmu_1066a(148) = 117.900000000000
- M1066a_V%Qmu_1066a(149) = 117.900000000000
- M1066a_V%Qmu_1066a(150) = 117.900000000000
- M1066a_V%Qmu_1066a(151) = 117.900000000000
- M1066a_V%Qmu_1066a(152) = 117.900000000000
- M1066a_V%Qmu_1066a(153) = 117.900000000000
- M1066a_V%Qmu_1066a(154) = 117.900000000000
- M1066a_V%Qmu_1066a(155) = 117.900000000000
- M1066a_V%Qmu_1066a(156) = 117.900000000000
- M1066a_V%Qmu_1066a(157) = 117.900000000000
- M1066a_V%Qmu_1066a(158) = 117.900000000000
- M1066a_V%Qmu_1066a(159) = 117.900000000000
- M1066a_V%Qmu_1066a(160) = 117.900000000000
-
-! strip the crust and replace it by mantle if we use an external crustal model
- if(USE_EXTERNAL_CRUSTAL_MODEL) then
- do i=NR_1066A-3,NR_1066A
- M1066a_V%density_1066a(i) = M1066a_V%density_1066a(NR_1066A-4)
- M1066a_V%vp_1066a(i) = M1066a_V%vp_1066a(NR_1066A-4)
- M1066a_V%vs_1066a(i) = M1066a_V%vs_1066a(NR_1066A-4)
- M1066a_V%Qkappa_1066a(i) = M1066a_V%Qkappa_1066a(NR_1066A-4)
- M1066a_V%Qmu_1066a(i) = M1066a_V%Qmu_1066a(NR_1066A-4)
- enddo
- endif
-
- end subroutine define_model_1066a
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ak135.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ak135.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ak135.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,1038 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 model_ak135(x,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V)
-
- implicit none
-
- include "constants.h"
-
-! 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
-
-! input:
-! radius r: meters
-
-! output:
-! density rho: kg/m^3
-! compressional wave speed vp: km/s
-! shear wave speed vs: km/s
-
- integer iregion_code
-
- double precision x,rho,vp,vs,Qmu,Qkappa
-
- integer i
-
- double precision r,frac,scaleval
-
-!! DK DK UGLY implementation of model ak135 below and its radii in
-!! DK DK UGLY subroutine read_parameter_file.f90 has not been thoroughly
-!! DK DK UGLY checked yet
-
-! compute real physical radius in meters
- r = x * R_EARTH
-
- i = 1
- do while(r >= Mak135_V%radius_ak135(i) .and. i /= NR_AK135)
- i = i + 1
- enddo
-
-! make sure we stay in the right region and never take a point above
-! and a point below the ICB or the CMB and interpolate between them,
-! which would lead to a wrong value (keeping in mind that we interpolate
-! between points i-1 and i below)
- if(iregion_code == IREGION_INNER_CORE .and. i > 25) i = 25
-
- if(iregion_code == IREGION_OUTER_CORE .and. i < 27) i = 27
- if(iregion_code == IREGION_OUTER_CORE .and. i > 71) i = 71
-
- if(iregion_code == IREGION_CRUST_MANTLE .and. i < 73) i = 73
-
- if(i == 1) then
- rho = Mak135_V%density_ak135(i)
- vp = Mak135_V%vp_ak135(i)
- vs = Mak135_V%vs_ak135(i)
- Qmu = Mak135_V%Qmu_ak135(i)
- Qkappa = Mak135_V%Qkappa_ak135(i)
- else
-
-! interpolate from radius_ak135(i-1) to r using the values at i-1 and i
- frac = (r-Mak135_V%radius_ak135(i-1))/(Mak135_V%radius_ak135(i)-Mak135_V%radius_ak135(i-1))
-
- rho = Mak135_V%density_ak135(i-1) + frac * (Mak135_V%density_ak135(i)-Mak135_V%density_ak135(i-1))
- vp = Mak135_V%vp_ak135(i-1) + frac * (Mak135_V%vp_ak135(i)-Mak135_V%vp_ak135(i-1))
- vs = Mak135_V%vs_ak135(i-1) + frac * (Mak135_V%vs_ak135(i)-Mak135_V%vs_ak135(i-1))
- Qmu = Mak135_V%Qmu_ak135(i-1) + frac * (Mak135_V%Qmu_ak135(i)-Mak135_V%Qmu_ak135(i-1))
- Qkappa = Mak135_V%Qkappa_ak135(i-1) + frac * (Mak135_V%Qkappa_ak135(i)-Mak135_V%Qkappa_ak135(i-1))
-
- endif
-
-! make sure Vs is zero in the outer core even if roundoff errors on depth
-! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
- if(iregion_code == IREGION_OUTER_CORE) then
- vs = 0.d0
- Qkappa = 3000.d0
- Qmu = 3000.d0
- endif
-
-! non-dimensionalize
-! time scaling (s^{-1}) is done with scaleval
- scaleval=dsqrt(PI*GRAV*RHOAV)
- rho=rho*1000.0d0/RHOAV
- vp=vp*1000.0d0/(R_EARTH*scaleval)
- vs=vs*1000.0d0/(R_EARTH*scaleval)
-
- end subroutine model_ak135
-
-!-------------------
-
- subroutine define_model_ak135(USE_EXTERNAL_CRUSTAL_MODEL,Mak135_V)
-
- implicit none
- include "constants.h"
-
-! 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
-
- logical USE_EXTERNAL_CRUSTAL_MODEL
-
- integer i
-
-! define all the values in the model
-
- Mak135_V%radius_ak135( 1) = 0.000000000000000
- Mak135_V%radius_ak135( 2) = 50710.0000000000
- Mak135_V%radius_ak135( 3) = 101430.000000000
- Mak135_V%radius_ak135( 4) = 152140.000000000
- Mak135_V%radius_ak135( 5) = 202850.000000000
- Mak135_V%radius_ak135( 6) = 253560.000000000
- Mak135_V%radius_ak135( 7) = 304280.000000000
- Mak135_V%radius_ak135( 8) = 354990.000000000
- Mak135_V%radius_ak135( 9) = 405700.000000000
- Mak135_V%radius_ak135( 10) = 456410.000000000
- Mak135_V%radius_ak135( 11) = 507130.000000000
- Mak135_V%radius_ak135( 12) = 557840.000000000
- Mak135_V%radius_ak135( 13) = 608550.000000000
- Mak135_V%radius_ak135( 14) = 659260.000000000
- Mak135_V%radius_ak135( 15) = 709980.000000000
- Mak135_V%radius_ak135( 16) = 760690.000000000
- Mak135_V%radius_ak135( 17) = 811400.000000000
- Mak135_V%radius_ak135( 18) = 862110.000000000
- Mak135_V%radius_ak135( 19) = 912830.000000000
- Mak135_V%radius_ak135( 20) = 963540.000000000
- Mak135_V%radius_ak135( 21) = 1014250.00000000
- Mak135_V%radius_ak135( 22) = 1064960.00000000
- Mak135_V%radius_ak135( 23) = 1115680.00000000
- Mak135_V%radius_ak135( 24) = 1166390.00000000
- Mak135_V%radius_ak135( 25) = 1217500.00000000
- Mak135_V%radius_ak135( 26) = 1217500.00000000
- Mak135_V%radius_ak135( 27) = 1267430.00000000
- Mak135_V%radius_ak135( 28) = 1317760.00000000
- Mak135_V%radius_ak135( 29) = 1368090.00000000
- Mak135_V%radius_ak135( 30) = 1418420.00000000
- Mak135_V%radius_ak135( 31) = 1468760.00000000
- Mak135_V%radius_ak135( 32) = 1519090.00000000
- Mak135_V%radius_ak135( 33) = 1569420.00000000
- Mak135_V%radius_ak135( 34) = 1619750.00000000
- Mak135_V%radius_ak135( 35) = 1670080.00000000
- Mak135_V%radius_ak135( 36) = 1720410.00000000
- Mak135_V%radius_ak135( 37) = 1770740.00000000
- Mak135_V%radius_ak135( 38) = 1821070.00000000
- Mak135_V%radius_ak135( 39) = 1871400.00000000
- Mak135_V%radius_ak135( 40) = 1921740.00000000
- Mak135_V%radius_ak135( 41) = 1972070.00000000
- Mak135_V%radius_ak135( 42) = 2022400.00000000
- Mak135_V%radius_ak135( 43) = 2072730.00000000
- Mak135_V%radius_ak135( 44) = 2123060.00000000
- Mak135_V%radius_ak135( 45) = 2173390.00000000
- Mak135_V%radius_ak135( 46) = 2223720.00000000
- Mak135_V%radius_ak135( 47) = 2274050.00000000
- Mak135_V%radius_ak135( 48) = 2324380.00000000
- Mak135_V%radius_ak135( 49) = 2374720.00000000
- Mak135_V%radius_ak135( 50) = 2425050.00000000
- Mak135_V%radius_ak135( 51) = 2475380.00000000
- Mak135_V%radius_ak135( 52) = 2525710.00000000
- Mak135_V%radius_ak135( 53) = 2576040.00000000
- Mak135_V%radius_ak135( 54) = 2626370.00000000
- Mak135_V%radius_ak135( 55) = 2676700.00000000
- Mak135_V%radius_ak135( 56) = 2727030.00000000
- Mak135_V%radius_ak135( 57) = 2777360.00000000
- Mak135_V%radius_ak135( 58) = 2827700.00000000
- Mak135_V%radius_ak135( 59) = 2878030.00000000
- Mak135_V%radius_ak135( 60) = 2928360.00000000
- Mak135_V%radius_ak135( 61) = 2978690.00000000
- Mak135_V%radius_ak135( 62) = 3029020.00000000
- Mak135_V%radius_ak135( 63) = 3079350.00000000
- Mak135_V%radius_ak135( 64) = 3129680.00000000
- Mak135_V%radius_ak135( 65) = 3180010.00000000
- Mak135_V%radius_ak135( 66) = 3230340.00000000
- Mak135_V%radius_ak135( 67) = 3280680.00000000
- Mak135_V%radius_ak135( 68) = 3331010.00000000
- Mak135_V%radius_ak135( 69) = 3381340.00000000
- Mak135_V%radius_ak135( 70) = 3431670.00000000
- Mak135_V%radius_ak135( 71) = 3479500.00000000
- Mak135_V%radius_ak135( 72) = 3479500.00000000
- Mak135_V%radius_ak135( 73) = 3531670.00000000
- Mak135_V%radius_ak135( 74) = 3581330.00000000
- Mak135_V%radius_ak135( 75) = 3631000.00000000
- Mak135_V%radius_ak135( 76) = 3631000.00000000
- Mak135_V%radius_ak135( 77) = 3681000.00000000
- Mak135_V%radius_ak135( 78) = 3731000.00000000
- Mak135_V%radius_ak135( 79) = 3779500.00000000
- Mak135_V%radius_ak135( 80) = 3829000.00000000
- Mak135_V%radius_ak135( 81) = 3878500.00000000
- Mak135_V%radius_ak135( 82) = 3928000.00000000
- Mak135_V%radius_ak135( 83) = 3977500.00000000
- Mak135_V%radius_ak135( 84) = 4027000.00000000
- Mak135_V%radius_ak135( 85) = 4076500.00000000
- Mak135_V%radius_ak135( 86) = 4126000.00000000
- Mak135_V%radius_ak135( 87) = 4175500.00000000
- Mak135_V%radius_ak135( 88) = 4225000.00000000
- Mak135_V%radius_ak135( 89) = 4274500.00000000
- Mak135_V%radius_ak135( 90) = 4324000.00000000
- Mak135_V%radius_ak135( 91) = 4373500.00000000
- Mak135_V%radius_ak135( 92) = 4423000.00000000
- Mak135_V%radius_ak135( 93) = 4472500.00000000
- Mak135_V%radius_ak135( 94) = 4522000.00000000
- Mak135_V%radius_ak135( 95) = 4571500.00000000
- Mak135_V%radius_ak135( 96) = 4621000.00000000
- Mak135_V%radius_ak135( 97) = 4670500.00000000
- Mak135_V%radius_ak135( 98) = 4720000.00000000
- Mak135_V%radius_ak135( 99) = 4769500.00000000
- Mak135_V%radius_ak135(100) = 4819000.00000000
- Mak135_V%radius_ak135(101) = 4868500.00000000
- Mak135_V%radius_ak135(102) = 4918000.00000000
- Mak135_V%radius_ak135(103) = 4967500.00000000
- Mak135_V%radius_ak135(104) = 5017000.00000000
- Mak135_V%radius_ak135(105) = 5066500.00000000
- Mak135_V%radius_ak135(106) = 5116000.00000000
- Mak135_V%radius_ak135(107) = 5165500.00000000
- Mak135_V%radius_ak135(108) = 5215000.00000000
- Mak135_V%radius_ak135(109) = 5264500.00000000
- Mak135_V%radius_ak135(110) = 5314000.00000000
- Mak135_V%radius_ak135(111) = 5363500.00000000
- Mak135_V%radius_ak135(112) = 5413000.00000000
- Mak135_V%radius_ak135(113) = 5462500.00000000
- Mak135_V%radius_ak135(114) = 5512000.00000000
- Mak135_V%radius_ak135(115) = 5561500.00000000
- Mak135_V%radius_ak135(116) = 5611000.00000000
- Mak135_V%radius_ak135(117) = 5661000.00000000
- Mak135_V%radius_ak135(118) = 5711000.00000000
- Mak135_V%radius_ak135(119) = 5711000.00000000
- Mak135_V%radius_ak135(120) = 5761000.00000000
- Mak135_V%radius_ak135(121) = 5811000.00000000
- Mak135_V%radius_ak135(122) = 5861000.00000000
- Mak135_V%radius_ak135(123) = 5911000.00000000
- Mak135_V%radius_ak135(124) = 5961000.00000000
- Mak135_V%radius_ak135(125) = 5961000.00000000
- Mak135_V%radius_ak135(126) = 6011000.00000000
- Mak135_V%radius_ak135(127) = 6061000.00000000
- Mak135_V%radius_ak135(128) = 6111000.00000000
- Mak135_V%radius_ak135(129) = 6161000.00000000
- Mak135_V%radius_ak135(130) = 6161000.00000000
- Mak135_V%radius_ak135(131) = 6206000.00000000
- Mak135_V%radius_ak135(132) = 6251000.00000000
- Mak135_V%radius_ak135(133) = 6291000.00000000
- Mak135_V%radius_ak135(134) = 6291000.00000000
- Mak135_V%radius_ak135(135) = 6328000.00000000
- Mak135_V%radius_ak135(136) = 6353000.00000000
- Mak135_V%radius_ak135(137) = 6353000.00000000
- Mak135_V%radius_ak135(138) = 6361000.00000000
- Mak135_V%radius_ak135(139) = 6361000.00000000
- Mak135_V%radius_ak135(140) = 6367700.00000000
- Mak135_V%radius_ak135(141) = 6367700.00000000
- Mak135_V%radius_ak135(142) = 6368000.00000000
- Mak135_V%radius_ak135(143) = 6368000.00000000
- Mak135_V%radius_ak135(144) = 6371000.00000000
-
- Mak135_V%density_ak135( 1) = 13.0122000000000
- Mak135_V%density_ak135( 2) = 13.0117000000000
- Mak135_V%density_ak135( 3) = 13.0100000000000
- Mak135_V%density_ak135( 4) = 13.0074000000000
- Mak135_V%density_ak135( 5) = 13.0036000000000
- Mak135_V%density_ak135( 6) = 12.9988000000000
- Mak135_V%density_ak135( 7) = 12.9929000000000
- Mak135_V%density_ak135( 8) = 12.9859000000000
- Mak135_V%density_ak135( 9) = 12.9779000000000
- Mak135_V%density_ak135( 10) = 12.9688000000000
- Mak135_V%density_ak135( 11) = 12.9586000000000
- Mak135_V%density_ak135( 12) = 12.9474000000000
- Mak135_V%density_ak135( 13) = 12.9351000000000
- Mak135_V%density_ak135( 14) = 12.9217000000000
- Mak135_V%density_ak135( 15) = 12.9072000000000
- Mak135_V%density_ak135( 16) = 12.8917000000000
- Mak135_V%density_ak135( 17) = 12.8751000000000
- Mak135_V%density_ak135( 18) = 12.8574000000000
- Mak135_V%density_ak135( 19) = 12.8387000000000
- Mak135_V%density_ak135( 20) = 12.8188000000000
- Mak135_V%density_ak135( 21) = 12.7980000000000
- Mak135_V%density_ak135( 22) = 12.7760000000000
- Mak135_V%density_ak135( 23) = 12.7530000000000
- Mak135_V%density_ak135( 24) = 12.7289000000000
- Mak135_V%density_ak135( 25) = 12.7037000000000
- Mak135_V%density_ak135( 26) = 12.1391000000000
- Mak135_V%density_ak135( 27) = 12.1133000000000
- Mak135_V%density_ak135( 28) = 12.0867000000000
- Mak135_V%density_ak135( 29) = 12.0593000000000
- Mak135_V%density_ak135( 30) = 12.0311000000000
- Mak135_V%density_ak135( 31) = 12.0001000000000
- Mak135_V%density_ak135( 32) = 11.9722000000000
- Mak135_V%density_ak135( 33) = 11.9414000000000
- Mak135_V%density_ak135( 34) = 11.9098000000000
- Mak135_V%density_ak135( 35) = 11.8772000000000
- Mak135_V%density_ak135( 36) = 11.8437000000000
- Mak135_V%density_ak135( 37) = 11.8092000000000
- Mak135_V%density_ak135( 38) = 11.7737000000000
- Mak135_V%density_ak135( 39) = 11.7373000000000
- Mak135_V%density_ak135( 40) = 11.6998000000000
- Mak135_V%density_ak135( 41) = 11.6612000000000
- Mak135_V%density_ak135( 42) = 11.6216000000000
- Mak135_V%density_ak135( 43) = 11.5809000000000
- Mak135_V%density_ak135( 44) = 11.5391000000000
- Mak135_V%density_ak135( 45) = 11.4962000000000
- Mak135_V%density_ak135( 46) = 11.4521000000000
- Mak135_V%density_ak135( 47) = 11.4069000000000
- Mak135_V%density_ak135( 48) = 11.3604000000000
- Mak135_V%density_ak135( 49) = 11.3127000000000
- Mak135_V%density_ak135( 50) = 11.2639000000000
- Mak135_V%density_ak135( 51) = 11.2137000000000
- Mak135_V%density_ak135( 52) = 11.1623000000000
- Mak135_V%density_ak135( 53) = 11.1095000000000
- Mak135_V%density_ak135( 54) = 11.0555000000000
- Mak135_V%density_ak135( 55) = 11.0001000000000
- Mak135_V%density_ak135( 56) = 10.9434000000000
- Mak135_V%density_ak135( 57) = 10.8852000000000
- Mak135_V%density_ak135( 58) = 10.8257000000000
- Mak135_V%density_ak135( 59) = 10.7647000000000
- Mak135_V%density_ak135( 60) = 10.7023000000000
- Mak135_V%density_ak135( 61) = 10.6385000000000
- Mak135_V%density_ak135( 62) = 10.5731000000000
- Mak135_V%density_ak135( 63) = 10.5062000000000
- Mak135_V%density_ak135( 64) = 10.4378000000000
- Mak135_V%density_ak135( 65) = 10.3679000000000
- Mak135_V%density_ak135( 66) = 10.2964000000000
- Mak135_V%density_ak135( 67) = 10.2233000000000
- Mak135_V%density_ak135( 68) = 10.1485000000000
- Mak135_V%density_ak135( 69) = 10.0722000000000
- Mak135_V%density_ak135( 70) = 9.99420000000000
- Mak135_V%density_ak135( 71) = 9.91450000000000
- Mak135_V%density_ak135( 72) = 5.77210000000000
- Mak135_V%density_ak135( 73) = 5.74580000000000
- Mak135_V%density_ak135( 74) = 5.71960000000000
- Mak135_V%density_ak135( 75) = 5.69340000000000
- Mak135_V%density_ak135( 76) = 5.43870000000000
- Mak135_V%density_ak135( 77) = 5.41760000000000
- Mak135_V%density_ak135( 78) = 5.39620000000000
- Mak135_V%density_ak135( 79) = 5.37480000000000
- Mak135_V%density_ak135( 80) = 5.35310000000000
- Mak135_V%density_ak135( 81) = 5.33130000000000
- Mak135_V%density_ak135( 82) = 5.30920000000000
- Mak135_V%density_ak135( 83) = 5.28700000000000
- Mak135_V%density_ak135( 84) = 5.26460000000000
- Mak135_V%density_ak135( 85) = 5.24200000000000
- Mak135_V%density_ak135( 86) = 5.21920000000000
- Mak135_V%density_ak135( 87) = 5.19630000000000
- Mak135_V%density_ak135( 88) = 5.17320000000000
- Mak135_V%density_ak135( 89) = 5.14990000000000
- Mak135_V%density_ak135( 90) = 5.12640000000000
- Mak135_V%density_ak135( 91) = 5.10270000000000
- Mak135_V%density_ak135( 92) = 5.07890000000000
- Mak135_V%density_ak135( 93) = 5.05480000000000
- Mak135_V%density_ak135( 94) = 5.03060000000000
- Mak135_V%density_ak135( 95) = 5.00620000000000
- Mak135_V%density_ak135( 96) = 4.98170000000000
- Mak135_V%density_ak135( 97) = 4.95700000000000
- Mak135_V%density_ak135( 98) = 4.93210000000000
- Mak135_V%density_ak135( 99) = 4.90690000000000
- Mak135_V%density_ak135(100) = 4.88170000000000
- Mak135_V%density_ak135(101) = 4.85620000000000
- Mak135_V%density_ak135(102) = 4.83070000000000
- Mak135_V%density_ak135(103) = 4.80500000000000
- Mak135_V%density_ak135(104) = 4.77900000000000
- Mak135_V%density_ak135(105) = 4.75280000000000
- Mak135_V%density_ak135(106) = 4.72660000000000
- Mak135_V%density_ak135(107) = 4.70010000000000
- Mak135_V%density_ak135(108) = 4.67350000000000
- Mak135_V%density_ak135(109) = 4.64670000000000
- Mak135_V%density_ak135(110) = 4.61980000000000
- Mak135_V%density_ak135(111) = 4.59260000000000
- Mak135_V%density_ak135(112) = 4.56540000000000
- Mak135_V%density_ak135(113) = 4.51620000000000
- Mak135_V%density_ak135(114) = 4.46500000000000
- Mak135_V%density_ak135(115) = 4.41180000000000
- Mak135_V%density_ak135(116) = 4.35650000000000
- Mak135_V%density_ak135(117) = 4.29860000000000
- Mak135_V%density_ak135(118) = 4.23870000000000
- Mak135_V%density_ak135(119) = 3.92010000000000
- Mak135_V%density_ak135(120) = 3.92060000000000
- Mak135_V%density_ak135(121) = 3.92180000000000
- Mak135_V%density_ak135(122) = 3.92330000000000
- Mak135_V%density_ak135(123) = 3.92730000000000
- Mak135_V%density_ak135(124) = 3.93170000000000
- Mak135_V%density_ak135(125) = 3.50680000000000
- Mak135_V%density_ak135(126) = 3.45770000000000
- Mak135_V%density_ak135(127) = 3.41100000000000
- Mak135_V%density_ak135(128) = 3.36630000000000
- Mak135_V%density_ak135(129) = 3.32430000000000
- Mak135_V%density_ak135(130) = 3.32430000000000
- Mak135_V%density_ak135(131) = 3.37110000000000
- Mak135_V%density_ak135(132) = 3.42680000000000
- Mak135_V%density_ak135(133) = 3.50200000000000
- Mak135_V%density_ak135(134) = 3.50200000000000
- Mak135_V%density_ak135(135) = 3.58010000000000
- Mak135_V%density_ak135(136) = 3.64100000000000
- Mak135_V%density_ak135(137) = 2.92000000000000
- Mak135_V%density_ak135(138) = 2.92000000000000
- Mak135_V%density_ak135(139) = 2.60000000000000
- Mak135_V%density_ak135(140) = 2.60000000000000
- Mak135_V%density_ak135(141) = 2.60000000000000
- Mak135_V%density_ak135(142) = 2.60000000000000
- Mak135_V%density_ak135(143) = 2.60000000000000
- Mak135_V%density_ak135(144) = 2.60000000000000
-
- Mak135_V%vp_ak135( 1) = 11.2622000000000
- Mak135_V%vp_ak135( 2) = 11.2618000000000
- Mak135_V%vp_ak135( 3) = 11.2606000000000
- Mak135_V%vp_ak135( 4) = 11.2586000000000
- Mak135_V%vp_ak135( 5) = 11.2557000000000
- Mak135_V%vp_ak135( 6) = 11.2521000000000
- Mak135_V%vp_ak135( 7) = 11.2477000000000
- Mak135_V%vp_ak135( 8) = 11.2424000000000
- Mak135_V%vp_ak135( 9) = 11.2364000000000
- Mak135_V%vp_ak135( 10) = 11.2295000000000
- Mak135_V%vp_ak135( 11) = 11.2219000000000
- Mak135_V%vp_ak135( 12) = 11.2134000000000
- Mak135_V%vp_ak135( 13) = 11.2041000000000
- Mak135_V%vp_ak135( 14) = 11.1941000000000
- Mak135_V%vp_ak135( 15) = 11.1832000000000
- Mak135_V%vp_ak135( 16) = 11.1715000000000
- Mak135_V%vp_ak135( 17) = 11.1590000000000
- Mak135_V%vp_ak135( 18) = 11.1457000000000
- Mak135_V%vp_ak135( 19) = 11.1316000000000
- Mak135_V%vp_ak135( 20) = 11.1166000000000
- Mak135_V%vp_ak135( 21) = 11.0983000000000
- Mak135_V%vp_ak135( 22) = 11.0850000000000
- Mak135_V%vp_ak135( 23) = 11.0718000000000
- Mak135_V%vp_ak135( 24) = 11.0585000000000
- Mak135_V%vp_ak135( 25) = 11.0427000000000
- Mak135_V%vp_ak135( 26) = 10.2890000000000
- Mak135_V%vp_ak135( 27) = 10.2854000000000
- Mak135_V%vp_ak135( 28) = 10.2745000000000
- Mak135_V%vp_ak135( 29) = 10.2565000000000
- Mak135_V%vp_ak135( 30) = 10.2329000000000
- Mak135_V%vp_ak135( 31) = 10.2049000000000
- Mak135_V%vp_ak135( 32) = 10.1739000000000
- Mak135_V%vp_ak135( 33) = 10.1415000000000
- Mak135_V%vp_ak135( 34) = 10.1095000000000
- Mak135_V%vp_ak135( 35) = 10.0768000000000
- Mak135_V%vp_ak135( 36) = 10.0439000000000
- Mak135_V%vp_ak135( 37) = 10.0103000000000
- Mak135_V%vp_ak135( 38) = 9.97610000000000
- Mak135_V%vp_ak135( 39) = 9.94100000000000
- Mak135_V%vp_ak135( 40) = 9.90510000000000
- Mak135_V%vp_ak135( 41) = 9.86820000000000
- Mak135_V%vp_ak135( 42) = 9.83040000000000
- Mak135_V%vp_ak135( 43) = 9.79140000000000
- Mak135_V%vp_ak135( 44) = 9.75130000000000
- Mak135_V%vp_ak135( 45) = 9.71000000000000
- Mak135_V%vp_ak135( 46) = 9.66730000000000
- Mak135_V%vp_ak135( 47) = 9.62320000000000
- Mak135_V%vp_ak135( 48) = 9.57770000000000
- Mak135_V%vp_ak135( 49) = 9.53060000000000
- Mak135_V%vp_ak135( 50) = 9.48140000000000
- Mak135_V%vp_ak135( 51) = 9.42970000000000
- Mak135_V%vp_ak135( 52) = 9.37600000000000
- Mak135_V%vp_ak135( 53) = 9.32050000000000
- Mak135_V%vp_ak135( 54) = 9.26340000000000
- Mak135_V%vp_ak135( 55) = 9.20420000000000
- Mak135_V%vp_ak135( 56) = 9.14260000000000
- Mak135_V%vp_ak135( 57) = 9.07920000000000
- Mak135_V%vp_ak135( 58) = 9.01380000000000
- Mak135_V%vp_ak135( 59) = 8.94610000000000
- Mak135_V%vp_ak135( 60) = 8.87610000000000
- Mak135_V%vp_ak135( 61) = 8.80360000000000
- Mak135_V%vp_ak135( 62) = 8.72830000000000
- Mak135_V%vp_ak135( 63) = 8.64960000000000
- Mak135_V%vp_ak135( 64) = 8.56920000000000
- Mak135_V%vp_ak135( 65) = 8.48610000000000
- Mak135_V%vp_ak135( 66) = 8.40010000000000
- Mak135_V%vp_ak135( 67) = 8.31220000000000
- Mak135_V%vp_ak135( 68) = 8.22130000000000
- Mak135_V%vp_ak135( 69) = 8.12830000000000
- Mak135_V%vp_ak135( 70) = 8.03820000000000
- Mak135_V%vp_ak135( 71) = 8.00000000000000
- Mak135_V%vp_ak135( 72) = 13.6601000000000
- Mak135_V%vp_ak135( 73) = 13.6570000000000
- Mak135_V%vp_ak135( 74) = 13.6533000000000
- Mak135_V%vp_ak135( 75) = 13.6498000000000
- Mak135_V%vp_ak135( 76) = 13.6498000000000
- Mak135_V%vp_ak135( 77) = 13.5899000000000
- Mak135_V%vp_ak135( 78) = 13.5311000000000
- Mak135_V%vp_ak135( 79) = 13.4741000000000
- Mak135_V%vp_ak135( 80) = 13.4156000000000
- Mak135_V%vp_ak135( 81) = 13.3584000000000
- Mak135_V%vp_ak135( 82) = 13.3017000000000
- Mak135_V%vp_ak135( 83) = 13.2465000000000
- Mak135_V%vp_ak135( 84) = 13.1895000000000
- Mak135_V%vp_ak135( 85) = 13.1337000000000
- Mak135_V%vp_ak135( 86) = 13.0786000000000
- Mak135_V%vp_ak135( 87) = 13.0226000000000
- Mak135_V%vp_ak135( 88) = 12.9663000000000
- Mak135_V%vp_ak135( 89) = 12.9093000000000
- Mak135_V%vp_ak135( 90) = 12.8524000000000
- Mak135_V%vp_ak135( 91) = 12.7956000000000
- Mak135_V%vp_ak135( 92) = 12.7384000000000
- Mak135_V%vp_ak135( 93) = 12.6807000000000
- Mak135_V%vp_ak135( 94) = 12.6226000000000
- Mak135_V%vp_ak135( 95) = 12.5638000000000
- Mak135_V%vp_ak135( 96) = 12.5030000000000
- Mak135_V%vp_ak135( 97) = 12.4427000000000
- Mak135_V%vp_ak135( 98) = 12.3813000000000
- Mak135_V%vp_ak135( 99) = 12.3181000000000
- Mak135_V%vp_ak135(100) = 12.2558000000000
- Mak135_V%vp_ak135(101) = 12.1912000000000
- Mak135_V%vp_ak135(102) = 12.1247000000000
- Mak135_V%vp_ak135(103) = 12.0571000000000
- Mak135_V%vp_ak135(104) = 11.9891000000000
- Mak135_V%vp_ak135(105) = 11.9208000000000
- Mak135_V%vp_ak135(106) = 11.8491000000000
- Mak135_V%vp_ak135(107) = 11.7768000000000
- Mak135_V%vp_ak135(108) = 11.7020000000000
- Mak135_V%vp_ak135(109) = 11.6265000000000
- Mak135_V%vp_ak135(110) = 11.5493000000000
- Mak135_V%vp_ak135(111) = 11.4704000000000
- Mak135_V%vp_ak135(112) = 11.3897000000000
- Mak135_V%vp_ak135(113) = 11.3068000000000
- Mak135_V%vp_ak135(114) = 11.2228000000000
- Mak135_V%vp_ak135(115) = 11.1355000000000
- Mak135_V%vp_ak135(116) = 11.0553000000000
- Mak135_V%vp_ak135(117) = 10.9222000000000
- Mak135_V%vp_ak135(118) = 10.7909000000000
- Mak135_V%vp_ak135(119) = 10.2000000000000
- Mak135_V%vp_ak135(120) = 10.0320000000000
- Mak135_V%vp_ak135(121) = 9.86400000000000
- Mak135_V%vp_ak135(122) = 9.69620000000000
- Mak135_V%vp_ak135(123) = 9.52800000000000
- Mak135_V%vp_ak135(124) = 9.36010000000000
- Mak135_V%vp_ak135(125) = 9.03020000000000
- Mak135_V%vp_ak135(126) = 8.84760000000000
- Mak135_V%vp_ak135(127) = 8.66500000000000
- Mak135_V%vp_ak135(128) = 8.48220000000000
- Mak135_V%vp_ak135(129) = 8.30070000000000
- Mak135_V%vp_ak135(130) = 8.30070000000000
- Mak135_V%vp_ak135(131) = 8.17500000000000
- Mak135_V%vp_ak135(132) = 8.05050000000000
- Mak135_V%vp_ak135(133) = 8.04500000000000
- Mak135_V%vp_ak135(134) = 8.04000000000000
- Mak135_V%vp_ak135(135) = 8.03790000000000
- Mak135_V%vp_ak135(136) = 8.03550000000000
- Mak135_V%vp_ak135(137) = 6.80000000000000
- Mak135_V%vp_ak135(138) = 6.80000000000000
- Mak135_V%vp_ak135(139) = 5.80000000000000
- Mak135_V%vp_ak135(140) = 5.80000000000000
- Mak135_V%vp_ak135(141) = 5.80000000000000
- Mak135_V%vp_ak135(142) = 5.80000000000000
- Mak135_V%vp_ak135(143) = 5.80000000000000
- Mak135_V%vp_ak135(144) = 5.80000000000000
-
- Mak135_V%vs_ak135( 1) = 3.66780000000000
- Mak135_V%vs_ak135( 2) = 3.66750000000000
- Mak135_V%vs_ak135( 3) = 3.66670000000000
- Mak135_V%vs_ak135( 4) = 3.66530000000000
- Mak135_V%vs_ak135( 5) = 3.66330000000000
- Mak135_V%vs_ak135( 6) = 3.66080000000000
- Mak135_V%vs_ak135( 7) = 3.65770000000000
- Mak135_V%vs_ak135( 8) = 3.65400000000000
- Mak135_V%vs_ak135( 9) = 3.64980000000000
- Mak135_V%vs_ak135( 10) = 3.64500000000000
- Mak135_V%vs_ak135( 11) = 3.63960000000000
- Mak135_V%vs_ak135( 12) = 3.63370000000000
- Mak135_V%vs_ak135( 13) = 3.62720000000000
- Mak135_V%vs_ak135( 14) = 3.62020000000000
- Mak135_V%vs_ak135( 15) = 3.61260000000000
- Mak135_V%vs_ak135( 16) = 3.60440000000000
- Mak135_V%vs_ak135( 17) = 3.59570000000000
- Mak135_V%vs_ak135( 18) = 3.58640000000000
- Mak135_V%vs_ak135( 19) = 3.57650000000000
- Mak135_V%vs_ak135( 20) = 3.56610000000000
- Mak135_V%vs_ak135( 21) = 3.55510000000000
- Mak135_V%vs_ak135( 22) = 3.54350000000000
- Mak135_V%vs_ak135( 23) = 3.53140000000000
- Mak135_V%vs_ak135( 24) = 3.51870000000000
- Mak135_V%vs_ak135( 25) = 3.50430000000000
- Mak135_V%vs_ak135( 26) = 0.000000000000000
- Mak135_V%vs_ak135( 27) = 0.000000000000000
- Mak135_V%vs_ak135( 28) = 0.000000000000000
- Mak135_V%vs_ak135( 29) = 0.000000000000000
- Mak135_V%vs_ak135( 30) = 0.000000000000000
- Mak135_V%vs_ak135( 31) = 0.000000000000000
- Mak135_V%vs_ak135( 32) = 0.000000000000000
- Mak135_V%vs_ak135( 33) = 0.000000000000000
- Mak135_V%vs_ak135( 34) = 0.000000000000000
- Mak135_V%vs_ak135( 35) = 0.000000000000000
- Mak135_V%vs_ak135( 36) = 0.000000000000000
- Mak135_V%vs_ak135( 37) = 0.000000000000000
- Mak135_V%vs_ak135( 38) = 0.000000000000000
- Mak135_V%vs_ak135( 39) = 0.000000000000000
- Mak135_V%vs_ak135( 40) = 0.000000000000000
- Mak135_V%vs_ak135( 41) = 0.000000000000000
- Mak135_V%vs_ak135( 42) = 0.000000000000000
- Mak135_V%vs_ak135( 43) = 0.000000000000000
- Mak135_V%vs_ak135( 44) = 0.000000000000000
- Mak135_V%vs_ak135( 45) = 0.000000000000000
- Mak135_V%vs_ak135( 46) = 0.000000000000000
- Mak135_V%vs_ak135( 47) = 0.000000000000000
- Mak135_V%vs_ak135( 48) = 0.000000000000000
- Mak135_V%vs_ak135( 49) = 0.000000000000000
- Mak135_V%vs_ak135( 50) = 0.000000000000000
- Mak135_V%vs_ak135( 51) = 0.000000000000000
- Mak135_V%vs_ak135( 52) = 0.000000000000000
- Mak135_V%vs_ak135( 53) = 0.000000000000000
- Mak135_V%vs_ak135( 54) = 0.000000000000000
- Mak135_V%vs_ak135( 55) = 0.000000000000000
- Mak135_V%vs_ak135( 56) = 0.000000000000000
- Mak135_V%vs_ak135( 57) = 0.000000000000000
- Mak135_V%vs_ak135( 58) = 0.000000000000000
- Mak135_V%vs_ak135( 59) = 0.000000000000000
- Mak135_V%vs_ak135( 60) = 0.000000000000000
- Mak135_V%vs_ak135( 61) = 0.000000000000000
- Mak135_V%vs_ak135( 62) = 0.000000000000000
- Mak135_V%vs_ak135( 63) = 0.000000000000000
- Mak135_V%vs_ak135( 64) = 0.000000000000000
- Mak135_V%vs_ak135( 65) = 0.000000000000000
- Mak135_V%vs_ak135( 66) = 0.000000000000000
- Mak135_V%vs_ak135( 67) = 0.000000000000000
- Mak135_V%vs_ak135( 68) = 0.000000000000000
- Mak135_V%vs_ak135( 69) = 0.000000000000000
- Mak135_V%vs_ak135( 70) = 0.000000000000000
- Mak135_V%vs_ak135( 71) = 0.000000000000000
- Mak135_V%vs_ak135( 72) = 7.28170000000000
- Mak135_V%vs_ak135( 73) = 7.27000000000000
- Mak135_V%vs_ak135( 74) = 7.25930000000000
- Mak135_V%vs_ak135( 75) = 7.24850000000000
- Mak135_V%vs_ak135( 76) = 7.24850000000000
- Mak135_V%vs_ak135( 77) = 7.22530000000000
- Mak135_V%vs_ak135( 78) = 7.20310000000000
- Mak135_V%vs_ak135( 79) = 7.18040000000000
- Mak135_V%vs_ak135( 80) = 7.15840000000000
- Mak135_V%vs_ak135( 81) = 7.13680000000000
- Mak135_V%vs_ak135( 82) = 7.11440000000000
- Mak135_V%vs_ak135( 83) = 7.09320000000000
- Mak135_V%vs_ak135( 84) = 7.07220000000000
- Mak135_V%vs_ak135( 85) = 7.05040000000000
- Mak135_V%vs_ak135( 86) = 7.02860000000000
- Mak135_V%vs_ak135( 87) = 7.00690000000000
- Mak135_V%vs_ak135( 88) = 6.98520000000000
- Mak135_V%vs_ak135( 89) = 6.96250000000000
- Mak135_V%vs_ak135( 90) = 6.94160000000000
- Mak135_V%vs_ak135( 91) = 6.91940000000000
- Mak135_V%vs_ak135( 92) = 6.89720000000000
- Mak135_V%vs_ak135( 93) = 6.87430000000000
- Mak135_V%vs_ak135( 94) = 6.85170000000000
- Mak135_V%vs_ak135( 95) = 6.82890000000000
- Mak135_V%vs_ak135( 96) = 6.80560000000000
- Mak135_V%vs_ak135( 97) = 6.78200000000000
- Mak135_V%vs_ak135( 98) = 6.75790000000000
- Mak135_V%vs_ak135( 99) = 6.73230000000000
- Mak135_V%vs_ak135(100) = 6.70700000000000
- Mak135_V%vs_ak135(101) = 6.68130000000000
- Mak135_V%vs_ak135(102) = 6.65540000000000
- Mak135_V%vs_ak135(103) = 6.62850000000000
- Mak135_V%vs_ak135(104) = 6.60090000000000
- Mak135_V%vs_ak135(105) = 6.57280000000000
- Mak135_V%vs_ak135(106) = 6.54310000000000
- Mak135_V%vs_ak135(107) = 6.51310000000000
- Mak135_V%vs_ak135(108) = 6.48220000000000
- Mak135_V%vs_ak135(109) = 6.45140000000000
- Mak135_V%vs_ak135(110) = 6.41820000000000
- Mak135_V%vs_ak135(111) = 6.38600000000000
- Mak135_V%vs_ak135(112) = 6.35190000000000
- Mak135_V%vs_ak135(113) = 6.31640000000000
- Mak135_V%vs_ak135(114) = 6.27990000000000
- Mak135_V%vs_ak135(115) = 6.24240000000000
- Mak135_V%vs_ak135(116) = 6.21000000000000
- Mak135_V%vs_ak135(117) = 6.08980000000000
- Mak135_V%vs_ak135(118) = 5.96070000000000
- Mak135_V%vs_ak135(119) = 5.61040000000000
- Mak135_V%vs_ak135(120) = 5.50470000000000
- Mak135_V%vs_ak135(121) = 5.39890000000000
- Mak135_V%vs_ak135(122) = 5.29220000000000
- Mak135_V%vs_ak135(123) = 5.18640000000000
- Mak135_V%vs_ak135(124) = 5.08060000000000
- Mak135_V%vs_ak135(125) = 4.87020000000000
- Mak135_V%vs_ak135(126) = 4.78320000000000
- Mak135_V%vs_ak135(127) = 4.69640000000000
- Mak135_V%vs_ak135(128) = 4.60940000000000
- Mak135_V%vs_ak135(129) = 4.51840000000000
- Mak135_V%vs_ak135(130) = 4.51840000000000
- Mak135_V%vs_ak135(131) = 4.50900000000000
- Mak135_V%vs_ak135(132) = 4.50000000000000
- Mak135_V%vs_ak135(133) = 4.49000000000000
- Mak135_V%vs_ak135(134) = 4.48000000000000
- Mak135_V%vs_ak135(135) = 4.48560000000000
- Mak135_V%vs_ak135(136) = 4.48390000000000
- Mak135_V%vs_ak135(137) = 3.90000000000000
- Mak135_V%vs_ak135(138) = 3.90000000000000
- Mak135_V%vs_ak135(139) = 3.20000000000000
- Mak135_V%vs_ak135(140) = 3.20000000000000
- Mak135_V%vs_ak135(141) = 3.20000000000000
- Mak135_V%vs_ak135(142) = 3.20000000000000
- Mak135_V%vs_ak135(143) = 3.20000000000000
- Mak135_V%vs_ak135(144) = 3.20000000000000
-
- if (SUPPRESS_CRUSTAL_MESH) then
- Mak135_V%vp_ak135(137:144) = Mak135_V%vp_ak135(136)
- Mak135_V%vs_ak135(137:144) = Mak135_V%vs_ak135(136)
- Mak135_V%density_ak135(137:144) = Mak135_V%density_ak135(136)
- endif
-
- Mak135_V%Qkappa_ak135( 1) = 601.270000000000
- Mak135_V%Qkappa_ak135( 2) = 601.320000000000
- Mak135_V%Qkappa_ak135( 3) = 601.460000000000
- Mak135_V%Qkappa_ak135( 4) = 601.700000000000
- Mak135_V%Qkappa_ak135( 5) = 602.050000000000
- Mak135_V%Qkappa_ak135( 6) = 602.490000000000
- Mak135_V%Qkappa_ak135( 7) = 603.040000000000
- Mak135_V%Qkappa_ak135( 8) = 603.690000000000
- Mak135_V%Qkappa_ak135( 9) = 604.440000000000
- Mak135_V%Qkappa_ak135( 10) = 605.280000000000
- Mak135_V%Qkappa_ak135( 11) = 606.260000000000
- Mak135_V%Qkappa_ak135( 12) = 607.310000000000
- Mak135_V%Qkappa_ak135( 13) = 608.480000000000
- Mak135_V%Qkappa_ak135( 14) = 609.740000000000
- Mak135_V%Qkappa_ak135( 15) = 611.120000000000
- Mak135_V%Qkappa_ak135( 16) = 612.620000000000
- Mak135_V%Qkappa_ak135( 17) = 614.210000000000
- Mak135_V%Qkappa_ak135( 18) = 615.930000000000
- Mak135_V%Qkappa_ak135( 19) = 617.780000000000
- Mak135_V%Qkappa_ak135( 20) = 619.710000000000
- Mak135_V%Qkappa_ak135( 21) = 621.500000000000
- Mak135_V%Qkappa_ak135( 22) = 624.080000000000
- Mak135_V%Qkappa_ak135( 23) = 626.870000000000
- Mak135_V%Qkappa_ak135( 24) = 629.890000000000
- Mak135_V%Qkappa_ak135( 25) = 633.260000000000
- Mak135_V%Qkappa_ak135( 26) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 27) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 28) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 29) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 30) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 31) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 32) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 33) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 34) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 35) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 36) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 37) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 38) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 39) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 40) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 41) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 42) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 43) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 44) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 45) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 46) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 47) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 48) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 49) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 50) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 51) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 52) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 53) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 54) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 55) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 56) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 57) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 58) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 59) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 60) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 61) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 62) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 63) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 64) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 65) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 66) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 67) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 68) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 69) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 70) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 71) = 57822.0000000000
- Mak135_V%Qkappa_ak135( 72) = 723.120000000000
- Mak135_V%Qkappa_ak135( 73) = 725.110000000000
- Mak135_V%Qkappa_ak135( 74) = 726.870000000000
- Mak135_V%Qkappa_ak135( 75) = 722.730000000000
- Mak135_V%Qkappa_ak135( 76) = 933.210000000000
- Mak135_V%Qkappa_ak135( 77) = 940.880000000000
- Mak135_V%Qkappa_ak135( 78) = 952.000000000000
- Mak135_V%Qkappa_ak135( 79) = 960.360000000000
- Mak135_V%Qkappa_ak135( 80) = 968.460000000000
- Mak135_V%Qkappa_ak135( 81) = 976.810000000000
- Mak135_V%Qkappa_ak135( 82) = 985.630000000000
- Mak135_V%Qkappa_ak135( 83) = 990.770000000000
- Mak135_V%Qkappa_ak135( 84) = 999.440000000000
- Mak135_V%Qkappa_ak135( 85) = 1008.79000000000
- Mak135_V%Qkappa_ak135( 86) = 1018.38000000000
- Mak135_V%Qkappa_ak135( 87) = 1032.14000000000
- Mak135_V%Qkappa_ak135( 88) = 1042.07000000000
- Mak135_V%Qkappa_ak135( 89) = 1048.09000000000
- Mak135_V%Qkappa_ak135( 90) = 1058.03000000000
- Mak135_V%Qkappa_ak135( 91) = 1064.23000000000
- Mak135_V%Qkappa_ak135( 92) = 1070.38000000000
- Mak135_V%Qkappa_ak135( 93) = 1085.97000000000
- Mak135_V%Qkappa_ak135( 94) = 1097.16000000000
- Mak135_V%Qkappa_ak135( 95) = 1108.58000000000
- Mak135_V%Qkappa_ak135( 96) = 1120.09000000000
- Mak135_V%Qkappa_ak135( 97) = 1127.02000000000
- Mak135_V%Qkappa_ak135( 98) = 1134.01000000000
- Mak135_V%Qkappa_ak135( 99) = 1141.32000000000
- Mak135_V%Qkappa_ak135(100) = 1148.76000000000
- Mak135_V%Qkappa_ak135(101) = 1156.04000000000
- Mak135_V%Qkappa_ak135(102) = 1163.16000000000
- Mak135_V%Qkappa_ak135(103) = 1170.53000000000
- Mak135_V%Qkappa_ak135(104) = 1178.19000000000
- Mak135_V%Qkappa_ak135(105) = 1186.06000000000
- Mak135_V%Qkappa_ak135(106) = 1193.99000000000
- Mak135_V%Qkappa_ak135(107) = 1202.04000000000
- Mak135_V%Qkappa_ak135(108) = 1210.02000000000
- Mak135_V%Qkappa_ak135(109) = 1217.91000000000
- Mak135_V%Qkappa_ak135(110) = 1226.52000000000
- Mak135_V%Qkappa_ak135(111) = 1234.54000000000
- Mak135_V%Qkappa_ak135(112) = 1243.02000000000
- Mak135_V%Qkappa_ak135(113) = 1251.69000000000
- Mak135_V%Qkappa_ak135(114) = 1260.68000000000
- Mak135_V%Qkappa_ak135(115) = 1269.44000000000
- Mak135_V%Qkappa_ak135(116) = 1277.93000000000
- Mak135_V%Qkappa_ak135(117) = 1311.17000000000
- Mak135_V%Qkappa_ak135(118) = 1350.54000000000
- Mak135_V%Qkappa_ak135(119) = 428.690000000000
- Mak135_V%Qkappa_ak135(120) = 425.510000000000
- Mak135_V%Qkappa_ak135(121) = 422.550000000000
- Mak135_V%Qkappa_ak135(122) = 419.940000000000
- Mak135_V%Qkappa_ak135(123) = 417.320000000000
- Mak135_V%Qkappa_ak135(124) = 413.660000000000
- Mak135_V%Qkappa_ak135(125) = 377.930000000000
- Mak135_V%Qkappa_ak135(126) = 366.340000000000
- Mak135_V%Qkappa_ak135(127) = 355.850000000000
- Mak135_V%Qkappa_ak135(128) = 346.370000000000
- Mak135_V%Qkappa_ak135(129) = 338.470000000000
- Mak135_V%Qkappa_ak135(130) = 200.970000000000
- Mak135_V%Qkappa_ak135(131) = 188.720000000000
- Mak135_V%Qkappa_ak135(132) = 182.570000000000
- Mak135_V%Qkappa_ak135(133) = 182.030000000000
- Mak135_V%Qkappa_ak135(134) = 1008.71000000000
- Mak135_V%Qkappa_ak135(135) = 972.770000000000
- Mak135_V%Qkappa_ak135(136) = 950.500000000000
- Mak135_V%Qkappa_ak135(137) = 1368.02000000000
- Mak135_V%Qkappa_ak135(138) = 1368.02000000000
- Mak135_V%Qkappa_ak135(139) = 1478.30000000000
- Mak135_V%Qkappa_ak135(140) = 1478.30000000000
- Mak135_V%Qkappa_ak135(141) = 1478.30000000000
- Mak135_V%Qkappa_ak135(142) = 1478.30000000000
- Mak135_V%Qkappa_ak135(143) = 1478.30000000000
- Mak135_V%Qkappa_ak135(144) = 1478.30000000000
-
- Mak135_V%Qmu_ak135( 1) = 85.0300000000000
- Mak135_V%Qmu_ak135( 2) = 85.0300000000000
- Mak135_V%Qmu_ak135( 3) = 85.0300000000000
- Mak135_V%Qmu_ak135( 4) = 85.0300000000000
- Mak135_V%Qmu_ak135( 5) = 85.0300000000000
- Mak135_V%Qmu_ak135( 6) = 85.0300000000000
- Mak135_V%Qmu_ak135( 7) = 85.0300000000000
- Mak135_V%Qmu_ak135( 8) = 85.0300000000000
- Mak135_V%Qmu_ak135( 9) = 85.0300000000000
- Mak135_V%Qmu_ak135( 10) = 85.0300000000000
- Mak135_V%Qmu_ak135( 11) = 85.0300000000000
- Mak135_V%Qmu_ak135( 12) = 85.0300000000000
- Mak135_V%Qmu_ak135( 13) = 85.0300000000000
- Mak135_V%Qmu_ak135( 14) = 85.0300000000000
- Mak135_V%Qmu_ak135( 15) = 85.0300000000000
- Mak135_V%Qmu_ak135( 16) = 85.0300000000000
- Mak135_V%Qmu_ak135( 17) = 85.0300000000000
- Mak135_V%Qmu_ak135( 18) = 85.0300000000000
- Mak135_V%Qmu_ak135( 19) = 85.0300000000000
- Mak135_V%Qmu_ak135( 20) = 85.0300000000000
- Mak135_V%Qmu_ak135( 21) = 85.0300000000000
- Mak135_V%Qmu_ak135( 22) = 85.0300000000000
- Mak135_V%Qmu_ak135( 23) = 85.0300000000000
- Mak135_V%Qmu_ak135( 24) = 85.0300000000000
- Mak135_V%Qmu_ak135( 25) = 85.0300000000000
- Mak135_V%Qmu_ak135( 26) = 0.000000000000000
- Mak135_V%Qmu_ak135( 27) = 0.000000000000000
- Mak135_V%Qmu_ak135( 28) = 0.000000000000000
- Mak135_V%Qmu_ak135( 29) = 0.000000000000000
- Mak135_V%Qmu_ak135( 30) = 0.000000000000000
- Mak135_V%Qmu_ak135( 31) = 0.000000000000000
- Mak135_V%Qmu_ak135( 32) = 0.000000000000000
- Mak135_V%Qmu_ak135( 33) = 0.000000000000000
- Mak135_V%Qmu_ak135( 34) = 0.000000000000000
- Mak135_V%Qmu_ak135( 35) = 0.000000000000000
- Mak135_V%Qmu_ak135( 36) = 0.000000000000000
- Mak135_V%Qmu_ak135( 37) = 0.000000000000000
- Mak135_V%Qmu_ak135( 38) = 0.000000000000000
- Mak135_V%Qmu_ak135( 39) = 0.000000000000000
- Mak135_V%Qmu_ak135( 40) = 0.000000000000000
- Mak135_V%Qmu_ak135( 41) = 0.000000000000000
- Mak135_V%Qmu_ak135( 42) = 0.000000000000000
- Mak135_V%Qmu_ak135( 43) = 0.000000000000000
- Mak135_V%Qmu_ak135( 44) = 0.000000000000000
- Mak135_V%Qmu_ak135( 45) = 0.000000000000000
- Mak135_V%Qmu_ak135( 46) = 0.000000000000000
- Mak135_V%Qmu_ak135( 47) = 0.000000000000000
- Mak135_V%Qmu_ak135( 48) = 0.000000000000000
- Mak135_V%Qmu_ak135( 49) = 0.000000000000000
- Mak135_V%Qmu_ak135( 50) = 0.000000000000000
- Mak135_V%Qmu_ak135( 51) = 0.000000000000000
- Mak135_V%Qmu_ak135( 52) = 0.000000000000000
- Mak135_V%Qmu_ak135( 53) = 0.000000000000000
- Mak135_V%Qmu_ak135( 54) = 0.000000000000000
- Mak135_V%Qmu_ak135( 55) = 0.000000000000000
- Mak135_V%Qmu_ak135( 56) = 0.000000000000000
- Mak135_V%Qmu_ak135( 57) = 0.000000000000000
- Mak135_V%Qmu_ak135( 58) = 0.000000000000000
- Mak135_V%Qmu_ak135( 59) = 0.000000000000000
- Mak135_V%Qmu_ak135( 60) = 0.000000000000000
- Mak135_V%Qmu_ak135( 61) = 0.000000000000000
- Mak135_V%Qmu_ak135( 62) = 0.000000000000000
- Mak135_V%Qmu_ak135( 63) = 0.000000000000000
- Mak135_V%Qmu_ak135( 64) = 0.000000000000000
- Mak135_V%Qmu_ak135( 65) = 0.000000000000000
- Mak135_V%Qmu_ak135( 66) = 0.000000000000000
- Mak135_V%Qmu_ak135( 67) = 0.000000000000000
- Mak135_V%Qmu_ak135( 68) = 0.000000000000000
- Mak135_V%Qmu_ak135( 69) = 0.000000000000000
- Mak135_V%Qmu_ak135( 70) = 0.000000000000000
- Mak135_V%Qmu_ak135( 71) = 0.000000000000000
- Mak135_V%Qmu_ak135( 72) = 273.970000000000
- Mak135_V%Qmu_ak135( 73) = 273.970000000000
- Mak135_V%Qmu_ak135( 74) = 273.970000000000
- Mak135_V%Qmu_ak135( 75) = 271.740000000000
- Mak135_V%Qmu_ak135( 76) = 350.880000000000
- Mak135_V%Qmu_ak135( 77) = 354.610000000000
- Mak135_V%Qmu_ak135( 78) = 359.710000000000
- Mak135_V%Qmu_ak135( 79) = 363.640000000000
- Mak135_V%Qmu_ak135( 80) = 367.650000000000
- Mak135_V%Qmu_ak135( 81) = 371.750000000000
- Mak135_V%Qmu_ak135( 82) = 375.940000000000
- Mak135_V%Qmu_ak135( 83) = 378.790000000000
- Mak135_V%Qmu_ak135( 84) = 383.140000000000
- Mak135_V%Qmu_ak135( 85) = 387.600000000000
- Mak135_V%Qmu_ak135( 86) = 392.160000000000
- Mak135_V%Qmu_ak135( 87) = 398.410000000000
- Mak135_V%Qmu_ak135( 88) = 403.230000000000
- Mak135_V%Qmu_ak135( 89) = 406.500000000000
- Mak135_V%Qmu_ak135( 90) = 411.520000000000
- Mak135_V%Qmu_ak135( 91) = 414.940000000000
- Mak135_V%Qmu_ak135( 92) = 418.410000000000
- Mak135_V%Qmu_ak135( 93) = 425.530000000000
- Mak135_V%Qmu_ak135( 94) = 431.030000000000
- Mak135_V%Qmu_ak135( 95) = 436.680000000000
- Mak135_V%Qmu_ak135( 96) = 442.480000000000
- Mak135_V%Qmu_ak135( 97) = 446.430000000000
- Mak135_V%Qmu_ak135( 98) = 450.450000000000
- Mak135_V%Qmu_ak135( 99) = 454.550000000000
- Mak135_V%Qmu_ak135(100) = 458.720000000000
- Mak135_V%Qmu_ak135(101) = 462.960000000000
- Mak135_V%Qmu_ak135(102) = 467.290000000000
- Mak135_V%Qmu_ak135(103) = 471.700000000000
- Mak135_V%Qmu_ak135(104) = 476.190000000000
- Mak135_V%Qmu_ak135(105) = 480.770000000000
- Mak135_V%Qmu_ak135(106) = 485.440000000000
- Mak135_V%Qmu_ak135(107) = 490.200000000000
- Mak135_V%Qmu_ak135(108) = 495.050000000000
- Mak135_V%Qmu_ak135(109) = 500.000000000000
- Mak135_V%Qmu_ak135(110) = 505.050000000000
- Mak135_V%Qmu_ak135(111) = 510.200000000000
- Mak135_V%Qmu_ak135(112) = 515.460000000000
- Mak135_V%Qmu_ak135(113) = 520.830000000000
- Mak135_V%Qmu_ak135(114) = 526.320000000000
- Mak135_V%Qmu_ak135(115) = 531.910000000000
- Mak135_V%Qmu_ak135(116) = 537.630000000000
- Mak135_V%Qmu_ak135(117) = 543.480000000000
- Mak135_V%Qmu_ak135(118) = 549.450000000000
- Mak135_V%Qmu_ak135(119) = 172.930000000000
- Mak135_V%Qmu_ak135(120) = 170.820000000000
- Mak135_V%Qmu_ak135(121) = 168.780000000000
- Mak135_V%Qmu_ak135(122) = 166.800000000000
- Mak135_V%Qmu_ak135(123) = 164.870000000000
- Mak135_V%Qmu_ak135(124) = 162.500000000000
- Mak135_V%Qmu_ak135(125) = 146.570000000000
- Mak135_V%Qmu_ak135(126) = 142.760000000000
- Mak135_V%Qmu_ak135(127) = 139.380000000000
- Mak135_V%Qmu_ak135(128) = 136.380000000000
- Mak135_V%Qmu_ak135(129) = 133.720000000000
- Mak135_V%Qmu_ak135(130) = 79.4000000000000
- Mak135_V%Qmu_ak135(131) = 76.5500000000000
- Mak135_V%Qmu_ak135(132) = 76.0600000000000
- Mak135_V%Qmu_ak135(133) = 75.6000000000000
- Mak135_V%Qmu_ak135(134) = 417.590000000000
- Mak135_V%Qmu_ak135(135) = 403.930000000000
- Mak135_V%Qmu_ak135(136) = 394.620000000000
- Mak135_V%Qmu_ak135(137) = 599.990000000000
- Mak135_V%Qmu_ak135(138) = 599.990000000000
- Mak135_V%Qmu_ak135(139) = 599.990000000000
- Mak135_V%Qmu_ak135(140) = 599.990000000000
- Mak135_V%Qmu_ak135(141) = 599.990000000000
- Mak135_V%Qmu_ak135(142) = 599.990000000000
- Mak135_V%Qmu_ak135(143) = 599.990000000000
- Mak135_V%Qmu_ak135(144) = 599.990000000000
-
-! strip the crust and replace it by mantle
- if(USE_EXTERNAL_CRUSTAL_MODEL) then
- do i=NR_AK135-8,NR_AK135
- Mak135_V%density_ak135(i) = Mak135_V%density_ak135(NR_AK135-9)
- Mak135_V%vp_ak135(i) = Mak135_V%vp_ak135(NR_AK135-9)
- Mak135_V%vs_ak135(i) = Mak135_V%vs_ak135(NR_AK135-9)
- Mak135_V%Qkappa_ak135(i) = Mak135_V%Qkappa_ak135(NR_AK135-9)
- Mak135_V%Qmu_ak135(i) = Mak135_V%Qmu_ak135(NR_AK135-9)
- enddo
- endif
-
- end subroutine define_model_ak135
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_iasp91.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_iasp91.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_iasp91.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,229 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_doubling_flag, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST)
-
- implicit none
-
- include "constants.h"
-
-! given a normalized radius x, gives the non-dimesionalized density rho,
-! speeds vp and vs, and the quality factors Qkappa and Qmu
-
- logical check_doubling_flag
-
- integer idoubling,myrank
-
- double precision x,rho,vp,vs,Qkappa,Qmu,RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST
-
- logical ONE_CRUST
-
- double precision r,scaleval
-
- double precision x1,x2
-
-! compute real physical radius in meters
- r = x * R_EARTH
-
- x1 = R120 / R_EARTH
- x2 = RMOHO / R_EARTH
-
-! check flags to make sure we correctly honor the discontinuities
-! we use strict inequalities since r has been slighly changed in mesher
-
- if(check_doubling_flag) then
-
-!
-!--- inner core
-!
- if(r >= 0.d0 .and. r < RICB) then
- if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
- idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
- call exit_MPI(myrank,'wrong doubling flag for inner core point')
-!
-!--- outer core
-!
- else if(r > RICB .and. r < RCMB) then
- if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for outer core point')
-!
-!--- D" at the base of the mantle
-!
- else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for D" point')
-!
-!--- mantle: from top of D" to d670
-!
- else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
-
-!
-!--- mantle: from d670 to d220
-!
- else if(r > R670 .and. r < R220) then
- if(idoubling /= IFLAG_670_220) &
- call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
-
-!
-!--- mantle and crust: from d220 to MOHO and then to surface
-!
- else if(r > R220) then
- if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
- call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
-
- endif
-
- endif
-
-!
-!--- inner core
-!
- if(r >= 0.d0 .and. r <= RICB) then
- rho=13.0885d0-8.8381d0*x*x
- vp=11.24094-4.09689*x**2
- vs=3.56454-3.45241*x**2
- Qmu=84.6d0
- Qkappa=1327.7d0
-!
-!--- outer core
-!
- else if(r > RICB .and. r <= RCMB) then
- rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
- vp=10.03904+3.75665*x-13.67046*x**2
- vs=0.0d0
- Qmu=0.0d0
- Qkappa=57827.0d0
-!
-!--- D" at the base of the mantle
-!
- else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vp=14.49470-1.47089*x
- vs=8.16616-1.58206*x
- Qmu=312.0d0
- Qkappa=57827.0d0
-
-!
-!--- mantle: from top of D" to d670
-!
- else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vp=25.1486-41.1538*x+51.9932*x**2-26.6083*x**3
- vs=12.9303-21.2590*x+27.8988*x**2-14.1080*x**3
- Qmu=312.0d0
- Qkappa=57827.0d0
- else if(r > R771 .and. r <= R670) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vp=25.96984-16.93412*x
- vs=20.76890-16.53147*x
- Qmu=312.0d0
- Qkappa=57827.0d0
-!
-!--- mantle: above d670
-!
- else if(r > R670 .and. r <= R400) then
- rho=5.3197d0-1.4836d0*x
- vp=29.38896-21.40656*x
- vs=17.70732-13.50652*x
- Qmu=143.0d0
- Qkappa=57827.0d0
- else if(r > R400 .and. r <= R220) then
- rho=7.1089d0-3.8045d0*x
- vp=30.78765-23.25415*x
- vs=15.24213-11.08552*x
- Qmu=143.0d0
- Qkappa=57827.0d0
-
-! from Sebastien Chevrot: for the IASP91 model
-! Depth R Vp Vs
-! 0-20 6351-6371 5.80 3.36
-! 20-35 6336-6351 6.50 3.75
-! 35-120 6251-6336 8.78541-0.74953 x 6.706231-2.248585 x
-! with x = r / 6371
-
- else if(r > R220 .and. r <= R120) then
- rho=2.6910d0+0.6924d0*x
- vp=25.41389-17.69722*x
- vs=5.75020-1.27420*x
- Qmu=80.0d0
- Qkappa=57827.0d0
-
- else if(r > R120 .and. r <= RMOHO) then
- vp = 8.78541d0-0.74953d0*x
- vs = 6.706231d0-2.248585d0*x
- rho = 3.3713d0 + (3.3198d0-3.3713d0)*(x-x1)/(x2-x1)
- if(rho < 3.30d0 .or. rho > 3.38d0) stop 'incorrect density computed for IASP91'
- Qmu=600.0d0
- Qkappa=57827.0d0
-
- else if (SUPPRESS_CRUSTAL_MESH) then
-!! DK DK extend the Moho up to the surface instead of the crust
- vp = 8.78541d0-0.74953d0*(RMOHO / R_EARTH)
- vs = 6.706231d0-2.248585d0*(RMOHO / R_EARTH)
- rho = 3.3198d0
- Qmu=600.0d0
- Qkappa=57827.0d0
-
- else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
- vp = 6.5d0
- vs = 3.75d0
- rho = 2.92d0
- Qmu=600.0d0
- Qkappa=57827.0d0
-
-! same properties everywhere in PREM crust if we decide to define only one layer in the crust
- if(ONE_CRUST) then
- vp = 5.8d0
- vs = 3.36d0
- rho = 2.72d0
- Qmu=600.0d0
- Qkappa=57827.0d0
- endif
-
- else
- vp = 5.8d0
- vs = 3.36d0
- rho = 2.72d0
- Qmu=600.0d0
- Qkappa=57827.0d0
- endif
-
-! non-dimensionalize
-! time scaling (s^{-1}) is done with scaleval
- scaleval=dsqrt(PI*GRAV*RHOAV)
- rho=rho*1000.0d0/RHOAV
- vp=vp*1000.0d0/(R_EARTH*scaleval)
- vs=vs*1000.0d0/(R_EARTH*scaleval)
-
- end subroutine model_iasp91
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_jp1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_jp1d.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_jp1d.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,204 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 model_jp1d(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling, &
- check_doubling_flag,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
-
- implicit none
-
- include "constants.h"
-
- ! given a normalized radius x, gives the non-dimesionalized density rho,
-! speeds vp and vs, and the quality factors Qkappa and Qmu
-
- logical check_doubling_flag
- integer idoubling,myrank
-
- double precision x,rho,vp,vs,Qkappa,Qmu,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST
-
- double precision r
- double precision scaleval
-
-! compute real physical radius in meters
- r = x * R_EARTH
-
-! check flags to make sure we correctly honor the discontinuities
-! we use strict inequalities since r has been slighly changed in mesher
-
- if(check_doubling_flag) then
-
-!--- inner core
-!
- if(r >= 0.d0 .and. r < RICB) then
- if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
- idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
- call exit_MPI(myrank,'wrong doubling flag for inner core point')
-!
-!--- outer core
-!
- else if(r > RICB .and. r < RCMB) then
- if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for outer core point')
-!
-!--- D" at the base of the mantle
-!
- else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for D" point')
-!
-!--- mantle: from top of D" to d670
-!
- else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
-
-!
-!--- mantle: from d670 to d220
-!
- else if(r > R670 .and. r < R220) then
- if(idoubling /= IFLAG_670_220) &
- call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
-
-!
-!--- mantle and crust: from d220 to MOHO and then to surface
-!
- else if(r > R220) then
- if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
- call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
-
- endif
-
- endif
-
-
-!
-!--- inner core
-!
- if (r >= 0.d0 .and. r <= RICB) then
- rho=13.0885d0-8.8381d0*x*x
- vp=11.24094-4.09689*x**2
- vs=3.56454-3.45241*x**2
- Qmu=84.6d0
- Qkappa=1327.7d0
-!
-!--- outer core
-!
- else if (r > RICB .and. r <= RCMB) then
- rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
- vp=10.03904+3.75665*x-13.67046*x**2
- vs=0.0d0
- Qmu=0.0d0
- Qkappa=57827.0d0
-!
-!--- D" at the base of the mantle
-!
- else if (r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vp=14.49470-1.47089*x
- vs=8.16616-1.58206*x
- Qmu=312.0d0
- Qkappa=57827.0d0
-!
-!--- mantle: from top of D" to d670
-!
- else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vp=-355.58324*x**4 + 1002.03178*x**3 - 1057.3873425*x**2 + 487.0891011*x - 68.520645
- vs=-243.33862*x**4 + 668.06411*x**3 - 685.20113*x**2 + 308.04893*x - 43.737642
- Qmu=312.0d0
- Qkappa=57827.0d0
- else if(r > R771 .and. r <= R670) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vp=-174.468866*x**2 + 286.37769*x - 106.034798
- vs=-81.0865*x*x + 129.67095*x - 45.268933
- Qmu=312.0d0
- Qkappa=57827.0d0
-!
-!--- mantle: above d670
-!
- else if(r > R670 .and. r <= 5871000.d0) then
- vp=-300.510146*x*x + 511.17372648*x - 206.265832
- vs=-139.78275*x*x + 233.3097462*x - 91.0129372
- rho=3.3d0 + (vs-4.4d0)*0.7d0
- Qmu=143.0d0
- Qkappa=57827.0d0
-
- else if(r > 5871000.d0 .and. r <= R400) then
- vp=-601.0202917*x*x + 1063.3823*x - 459.9388738
- vs=-145.2465705*x*x + 243.2807524*x - 95.561877
- rho=3.3d0 + (vs - 4.4d0)*0.7d0
- Qmu=143.0d0
- Qkappa=57827.0d0
-
- else if(r > R400 .and. r <= R220) then
- vp=25.042512155*x*x - 68.8367583*x + 51.4120272
- vs=15.540158021*x*x - 40.2087657*x + 28.9578929
- rho=3.3d0 + (vs - 4.4d0)*0.7d0
- Qmu=143.0d0
- Qkappa=57827.0d0
-
- else if(r > R220 .and. r <= R80) then
- vp=27.0989608 - 19.473338*x
- vs=13.920596 - 9.6309917*x
- rho=3.3d0 + (vs - 4.4d0)*0.7d0
- Qmu=80.0d0
- Qkappa=57827.0d0
-
- else if(r > R80 .and. r <= RMOHO) then
- vp=26.7663028 - 19.13645*x
- vs=13.4601434 - 9.164683*x
- rho=3.3d0 + (vs - 4.4d0)*0.7d0
- Qmu=600.0d0
- Qkappa=57827.0d0
-
- else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
- rho=2.9d0
- vp = 6.7d0
- vs = 3.8d0
- Qmu=600.0d0
- Qkappa=57827.0d0
- else
- rho=2.6d0
- vp = 6.0d0
- vs = 3.5d0
- Qmu=600.0d0
- Qkappa=57827.0d0
- end if
-
-
-! non-dimensionalize
-! time scaling (s^{-1}) is done with scaleval
- scaleval=dsqrt(PI*GRAV*RHOAV)
- rho=rho*1000.0d0/RHOAV
- vp=vp*1000.0d0/(R_EARTH*scaleval)
- vs=vs*1000.0d0/(R_EARTH*scaleval)
-end subroutine model_jp1d
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_prem.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_prem.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_prem.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,612 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, &
- ONE_CRUST,check_doubling_flag,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- implicit none
-
- include "constants.h"
-
-! given a normalized radius x, gives the non-dimesionalized density rho,
-! speeds vp and vs, and the quality factors Qkappa and Qmu
-
- logical CRUSTAL,ONE_CRUST,check_doubling_flag
-
- integer idoubling,myrank
-
- double precision x,rho,drhodr,vp,vs,Qkappa,Qmu,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- double precision r,scaleval
-
-! compute real physical radius in meters
- r = x * R_EARTH
-
-! check flags to make sure we correctly honor the discontinuities
-! we use strict inequalities since r has been slighly changed in mesher
-
- if(check_doubling_flag) then
-
-!
-!--- inner core
-!
-
- if(r >= 0.d0 .and. r < RICB) then
- if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
- idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
- call exit_MPI(myrank,'wrong doubling flag for inner core point')
-!
-!--- outer core
-!
- else if(r > RICB .and. r < RCMB) then
- if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for outer core point')
-!
-!--- D" at the base of the mantle
-!
- else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for D" point')
-!
-!--- mantle: from top of D" to d670
-!
- else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
-
-!
-!--- mantle: from d670 to d220
-!
- else if(r > R670 .and. r < R220) then
- if(idoubling /= IFLAG_670_220) &
- call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
-
-!
-!--- mantle and crust: from d220 to MOHO and then to surface
-!
- else if(r > R220) then
- if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
- call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
-
- endif
-
- endif
-
-!
-!--- inner core
-!
- if(r >= 0.d0 .and. r <= RICB) then
- drhodr=-2.0d0*8.8381d0*x
- rho=13.0885d0-8.8381d0*x*x
- vp=11.2622d0-6.3640d0*x*x
- vs=3.6678d0-4.4475d0*x*x
- Qmu=84.6d0
- Qkappa=1327.7d0
-!
-!--- outer core
-!
- else if(r > RICB .and. r <= RCMB) then
- drhodr=-1.2638d0-2.0d0*3.6426d0*x-3.0d0*5.5281d0*x*x
- rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
- vp=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
- vs=0.0d0
- Qmu=0.0d0
- Qkappa=57827.0d0
-!
-!--- D" at the base of the mantle
-!
- else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
- drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vp=15.3891d0-5.3181d0*x+5.5242d0*x*x-2.5514d0*x*x*x
- vs=6.9254d0+1.4672d0*x-2.0834d0*x*x+0.9783d0*x*x*x
- Qmu=312.0d0
- Qkappa=57827.0d0
-!
-!--- mantle: from top of D" to d670
-!
- else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
- drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vp=24.9520d0-40.4673d0*x+51.4832d0*x*x-26.6419d0*x*x*x
- vs=11.1671d0-13.7818d0*x+17.4575d0*x*x-9.2777d0*x*x*x
- Qmu=312.0d0
- Qkappa=57827.0d0
- else if(r > R771 .and. r <= R670) then
- drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vp=29.2766d0-23.6027d0*x+5.5242d0*x*x-2.5514d0*x*x*x
- vs=22.3459d0-17.2473d0*x-2.0834d0*x*x+0.9783d0*x*x*x
- Qmu=312.0d0
- Qkappa=57827.0d0
-!
-!--- mantle: above d670
-!
- else if(r > R670 .and. r <= R600) then
- drhodr=-1.4836d0
- rho=5.3197d0-1.4836d0*x
- vp=19.0957d0-9.8672d0*x
- vs=9.9839d0-4.9324d0*x
- Qmu=143.0d0
- Qkappa=57827.0d0
- else if(r > R600 .and. r <= R400) then
- drhodr=-8.0298d0
- rho=11.2494d0-8.0298d0*x
- vp=39.7027d0-32.6166d0*x
- vs=22.3512d0-18.5856d0*x
- Qmu=143.0d0
- Qkappa=57827.0d0
- else if(r > R400 .and. r <= R220) then
- drhodr=-3.8045d0
- rho=7.1089d0-3.8045d0*x
- vp=20.3926d0-12.2569d0*x
- vs=8.9496d0-4.4597d0*x
- Qmu=143.0d0
- Qkappa=57827.0d0
- else if(r > R220 .and. r <= R80) then
- drhodr=0.6924d0
- rho=2.6910d0+0.6924d0*x
- vp=4.1875d0+3.9382d0*x
- vs=2.1519d0+2.3481d0*x
- Qmu=80.0d0
- Qkappa=57827.0d0
- else
- if(CRUSTAL .and. .not. SUPPRESS_CRUSTAL_MESH) then
-! fill with PREM mantle and later add CRUST2.0
- if(r > R80) then
- drhodr=0.6924d0
- rho=2.6910d0+0.6924d0*x
- vp=4.1875d0+3.9382d0*x
- vs=2.1519d0+2.3481d0*x
- Qmu=600.0d0
- Qkappa=57827.0d0
- endif
- else
-! use PREM crust
- if(r > R80 .and. r <= RMOHO) then
- drhodr=0.6924d0
- rho=2.6910d0+0.6924d0*x
- vp=4.1875d0+3.9382d0*x
- vs=2.1519d0+2.3481d0*x
- Qmu=600.0d0
- Qkappa=57827.0d0
-
-
- else if (SUPPRESS_CRUSTAL_MESH) then
-!! DK DK extend the Moho up to the surface instead of the crust
- drhodr=0.6924d0
- rho = 2.6910d0+0.6924d0*(RMOHO / R_EARTH)
- vp = 4.1875d0+3.9382d0*(RMOHO / R_EARTH)
- vs = 2.1519d0+2.3481d0*(RMOHO / R_EARTH)
- Qmu=600.0d0
- Qkappa=57827.0d0
-
- else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
- drhodr=0.0d0
- rho=2.9d0
- vp=6.8d0
- vs=3.9d0
- Qmu=600.0d0
- Qkappa=57827.0d0
-
-! same properties everywhere in PREM crust if we decide to define only one layer in the crust
- if(ONE_CRUST) then
- drhodr=0.0d0
- rho=2.6d0
- vp=5.8d0
- vs=3.2d0
- Qmu=600.0d0
- Qkappa=57827.0d0
- endif
-
- else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
- drhodr=0.0d0
- rho=2.6d0
- vp=5.8d0
- vs=3.2d0
- Qmu=600.0d0
- Qkappa=57827.0d0
-! for density profile for gravity, we do not check that r <= R_EARTH
- else if(r > ROCEAN) then
- drhodr=0.0d0
- rho=2.6d0
- vp=5.8d0
- vs=3.2d0
- Qmu=600.0d0
- Qkappa=57827.0d0
-
- endif
- endif
- endif
-
-! non-dimensionalize
-! time scaling (s^{-1}) is done with scaleval
- scaleval=dsqrt(PI*GRAV*RHOAV)
- drhodr=drhodr*1000.0d0/RHOAV
- rho=rho*1000.0d0/RHOAV
- vp=vp*1000.0d0/(R_EARTH*scaleval)
- vs=vs*1000.0d0/(R_EARTH*scaleval)
-
- end subroutine prem_iso
-
-!
-!=====================================================================
-!
-
- subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, &
- idoubling,CRUSTAL,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- implicit none
-
- include "constants.h"
-
-! given a normalized radius x, gives the non-dimesionalized density rho,
-! speeds vp and vs, and the quality factors Qkappa and Qmu
-
- logical CRUSTAL,ONE_CRUST
-
- integer idoubling,myrank
-
- double precision x,rho,Qkappa,Qmu,vpv,vph,vsv,vsh,eta_aniso,RICB,RCMB, &
- RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- double precision r
- double precision scaleval
-
-! compute real physical radius in meters
- r = x * R_EARTH
-
-! check flags to make sure we correctly honor the discontinuities
-! we use strict inequalities since r has been slighly changed in mesher
-
-!
-!--- inner core
-!
- if(r >= 0.d0 .and. r < RICB) then
- if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
- idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
- idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
- call exit_MPI(myrank,'wrong doubling flag for inner core point')
-!
-!--- outer core
-!
- else if(r > RICB .and. r < RCMB) then
- if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for outer core point')
-!
-!--- D" at the base of the mantle
-!
- else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for D" point')
-!
-!--- mantle: from top of D" to d670
-!
- else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) &
- call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
-
-!
-!--- mantle: from d670 to d220
-!
- else if(r > R670 .and. r < R220) then
- if(idoubling /= IFLAG_670_220) &
- call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
-
-!
-!--- mantle and crust: from d220 to MOHO and then to surface
-!
- else if(r > R220) then
- if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
- call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
-
- endif
-
-! no anisotropy by default
- eta_aniso = 1.d0
-
-!
-!--- inner core
-!
- if(r >= 0.d0 .and. r <= RICB) then
- rho=13.0885d0-8.8381d0*x*x
- vpv=11.2622d0-6.3640d0*x*x
- vsv=3.6678d0-4.4475d0*x*x
- vph=vpv
- vsh=vsv
- Qmu=84.6d0
- Qkappa=1327.7d0
-!
-!--- outer core
-!
- else if(r > RICB .and. r <= RCMB) then
- rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
- vpv=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
- vsv=0.0d0
- vph=vpv
- vsh=vsv
- Qmu=0.0d0
- Qkappa=57827.0d0
-!
-!--- D" at the base of the mantle
-!
- else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vpv=15.3891d0-5.3181d0*x+5.5242d0*x*x-2.5514d0*x*x*x
- vsv=6.9254d0+1.4672d0*x-2.0834d0*x*x+0.9783d0*x*x*x
- vph=vpv
- vsh=vsv
- Qmu=312.0d0
- Qkappa=57827.0d0
-!
-!--- mantle: from top of D" to d670
-!
- else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vpv=24.9520d0-40.4673d0*x+51.4832d0*x*x-26.6419d0*x*x*x
- vsv=11.1671d0-13.7818d0*x+17.4575d0*x*x-9.2777d0*x*x*x
- vph=vpv
- vsh=vsv
- Qmu=312.0d0
- Qkappa=57827.0d0
- else if(r > R771 .and. r <= R670) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- vpv=29.2766d0-23.6027d0*x+5.5242d0*x*x-2.5514d0*x*x*x
- vsv=22.3459d0-17.2473d0*x-2.0834d0*x*x+0.9783d0*x*x*x
- vph=vpv
- vsh=vsv
- Qmu=312.0d0
- Qkappa=57827.0d0
-!
-!--- mantle: above d670
-!
- else if(r > R670 .and. r <= R600) then
- rho=5.3197d0-1.4836d0*x
- vpv=19.0957d0-9.8672d0*x
- vsv=9.9839d0-4.9324d0*x
- vph=vpv
- vsh=vsv
- Qmu=143.0d0
- Qkappa=57827.0d0
- else if(r > R600 .and. r <= R400) then
- rho=11.2494d0-8.0298d0*x
- vpv=39.7027d0-32.6166d0*x
- vsv=22.3512d0-18.5856d0*x
- vph=vpv
- vsh=vsv
- Qmu=143.0d0
- Qkappa=57827.0d0
- else if(r > R400 .and. r <= R220) then
- rho=7.1089d0-3.8045d0*x
- vpv=20.3926d0-12.2569d0*x
- vsv=8.9496d0-4.4597d0*x
- vph=vpv
- vsh=vsv
- Qmu=143.0d0
- Qkappa=57827.0d0
- else if(r > R220 .and. r <= R80) then
-
-! anisotropy in PREM only above 220 km
-
- rho=2.6910d0+0.6924d0*x
- vpv=0.8317d0+7.2180d0*x
- vph=3.5908d0+4.6172d0*x
- vsv=5.8582d0-1.4678d0*x
- vsh=-1.0839d0+5.7176d0*x
- eta_aniso=3.3687d0-2.4778d0*x
- Qmu=80.0d0
- Qkappa=57827.0d0
-
- else
- if(CRUSTAL) then
-! fill with PREM mantle and later add CRUST2.0
- if(r > R80) then
- rho=2.6910d0+0.6924d0*x
- vpv=0.8317d0+7.2180d0*x
- vph=3.5908d0+4.6172d0*x
- vsv=5.8582d0-1.4678d0*x
- vsh=-1.0839d0+5.7176d0*x
- eta_aniso=3.3687d0-2.4778d0*x
- Qmu=600.0d0
- Qkappa=57827.0d0
- endif
- else
-! use PREM crust
- if(r > R80 .and. r <= RMOHO) then
-
-! anisotropy in PREM only above 220 km
-
- rho=2.6910d0+0.6924d0*x
- vpv=0.8317d0+7.2180d0*x
- vph=3.5908d0+4.6172d0*x
- vsv=5.8582d0-1.4678d0*x
- vsh=-1.0839d0+5.7176d0*x
- eta_aniso=3.3687d0-2.4778d0*x
- Qmu=600.0d0
- Qkappa=57827.0d0
-
-! no anisotropy in the crust in PREM
-
- else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
- rho=2.9d0
- vpv=6.8d0
- vsv=3.9d0
- vph=vpv
- vsh=vsv
- Qmu=600.0d0
- Qkappa=57827.0d0
-
-! same properties everywhere in PREM crust (only one layer in the crust)
- if(ONE_CRUST) then
- rho=2.6d0
- vpv=5.8d0
- vsv=3.2d0
- vph=vpv
- vsh=vsv
- Qmu=600.0d0
- Qkappa=57827.0d0
- endif
-
- else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
- rho=2.6d0
- vpv=5.8d0
- vsv=3.2d0
- vph=vpv
- vsh=vsv
- Qmu=600.0d0
- Qkappa=57827.0d0
- else if(r > ROCEAN) then
- rho=2.6d0
- vpv=5.8d0
- vsv=3.2d0
- vph=vpv
- vsh=vsv
- Qmu=600.0d0
- Qkappa=57827.0d0
- endif
- endif
- endif
-
-! non-dimensionalize
-! time scaling (s^{-1}) is done with scaleval
-! do not scale anisotropy parameter eta_aniso, which is dimensionless
- scaleval=dsqrt(PI*GRAV*RHOAV)
- rho=rho*1000.0d0/RHOAV
- vpv=vpv*1000.0d0/(R_EARTH*scaleval)
- vsv=vsv*1000.0d0/(R_EARTH*scaleval)
- vph=vph*1000.0d0/(R_EARTH*scaleval)
- vsh=vsh*1000.0d0/(R_EARTH*scaleval)
-
- end subroutine prem_aniso
-
-!
-!=====================================================================
-!
-
- subroutine prem_display_outer_core(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling)
-
-! routine used for AVS or DX display of stability condition
-! and number of points per wavelength only in the fluid outer core
-
- implicit none
-
- include "constants.h"
-
-! given a normalized radius x, gives the non-dimesionalized density rho,
-! speeds vp and vs, and the quality factors Qkappa and Qmu
-
- integer idoubling,myrank
- double precision x,rho,vp,vs,Qkappa,Qmu
-
- double precision scaleval
-
- if(idoubling /= IFLAG_OUTER_CORE_NORMAL) call exit_MPI(myrank,'wrong doubling flag for outer core point')
-
-!
-!--- outer core
-!
- rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
- vp=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
- vs=0.0d0
- Qmu=0.0d0
- Qkappa=57827.0d0
-
-! non-dimensionalize
-! time scaling (s^{-1}) is done with scaleval
- scaleval = dsqrt(PI*GRAV*RHOAV)
- rho = rho*1000.0d0/RHOAV
- vp = vp*1000.0d0/(R_EARTH*scaleval)
- vs = vs*1000.0d0/(R_EARTH*scaleval)
-
- end subroutine prem_display_outer_core
-
-!
-!=====================================================================
-!
-
- subroutine prem_density(x,rho,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- implicit none
-
- include "constants.h"
-
- double precision x,rho,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- logical ONE_CRUST
-
- double precision r
-
- r = x * R_EARTH
-
- if(r <= RICB) then
- rho=13.0885d0-8.8381d0*x*x
- else if(r > RICB .and. r <= RCMB) then
- rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
- else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- else if(r > R771 .and. r <= R670) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- else if(r > R670 .and. r <= R600) then
- rho=5.3197d0-1.4836d0*x
- else if(r > R600 .and. r <= R400) then
- rho=11.2494d0-8.0298d0*x
- else if(r > R400 .and. r <= R220) then
- rho=7.1089d0-3.8045d0*x
- else if(r > R220 .and. r <= R80) then
- rho=2.6910d0+0.6924d0*x
- else
- if(r > R80 .and. r <= RMOHO) then
- rho=2.6910d0+0.6924d0*x
- else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
- if(ONE_CRUST) then
- rho=2.6d0
- else
- rho=2.9d0
- endif
- else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
- rho=2.6d0
- else if(r > ROCEAN) then
- rho=2.6d0
- endif
- endif
-
- rho=rho*1000.0d0/RHOAV
-
- end subroutine prem_density
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ref.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ref.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ref.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,7374 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 model_ref(x,rho,vpv,vph,vsv,vsh,eta,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
-
- implicit none
-
- include "constants.h"
-
-! 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
-
-! input:
-! dimensionless radius x
-
-! output: non-dimensionalized
-! mass density rho
-! compressional wave speed vpv
-! compressional wave speed vph
-! shear wave speed vsv
-! shear wave speed vsh
-! dimensionless parameter eta
-! shear quality factor Qmu
-! bulk quality factor Qkappa
-
- integer iregion_code
-
- double precision x,rho,vpv,vph,vsv,vsh,eta,Qmu,Qkappa
-
- integer i
-
- double precision r,frac,scaleval
- logical CRUSTAL
-
-! compute real physical radius in meters
- r = x * R_EARTH
-
- i = 1
- do while(r >= Mref_V%radius_ref(i) .and. i /= NR_REF)
- i = i + 1
- enddo
-
-! make sure we stay in the right region
- if(iregion_code == IREGION_INNER_CORE .and. i > 180) i = 180
-
- if(iregion_code == IREGION_OUTER_CORE .and. i < 182) i = 182
- if(iregion_code == IREGION_OUTER_CORE .and. i > 358) i = 358
-
- if(iregion_code == IREGION_CRUST_MANTLE .and. i < 360) i = 360
- if(CRUSTAL .and. i > 717) i = 717
-
-
- if(i == 1) then
- rho = Mref_V%density_ref(i)
- vpv = Mref_V%vpv_ref(i)
- vph = Mref_V%vph_ref(i)
- vsv = Mref_V%vsv_ref(i)
- vsh = Mref_V%vsh_ref(i)
- eta = Mref_V%eta_ref(i)
- Qkappa = Mref_V%Qkappa_ref(i)
- Qmu = Mref_V%Qmu_ref(i)
- else
-
-! interpolate from radius_ref(i-1) to r using the values at i-1 and i
- frac = (r-Mref_V%radius_ref(i-1))/(Mref_V%radius_ref(i)-Mref_V%radius_ref(i-1))
-
- rho = Mref_V%density_ref(i-1) + frac * (Mref_V%density_ref(i)-Mref_V%density_ref(i-1))
- vpv = Mref_V%vpv_ref(i-1) + frac * (Mref_V%vpv_ref(i)-Mref_V%vpv_ref(i-1))
- vph = Mref_V%vph_ref(i-1) + frac * (Mref_V%vph_ref(i)-Mref_V%vph_ref(i-1))
- vsv = Mref_V%vsv_ref(i-1) + frac * (Mref_V%vsv_ref(i)-Mref_V%vsv_ref(i-1))
- vsh = Mref_V%vsh_ref(i-1) + frac * (Mref_V%vsh_ref(i)-Mref_V%vsh_ref(i-1))
- eta = Mref_V%eta_ref(i-1) + frac * (Mref_V%eta_ref(i)-Mref_V%eta_ref(i-1))
- Qkappa = Mref_V%Qkappa_ref(i-1) + frac * (Mref_V%Qkappa_ref(i)-Mref_V%Qkappa_ref(i-1))
- Qmu = Mref_V%Qmu_ref(i-1) + frac * (Mref_V%Qmu_ref(i)-Mref_V%Qmu_ref(i-1))
-
- endif
-
-! make sure Vs is zero in the outer core even if roundoff errors on depth
-! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
- if(iregion_code == IREGION_OUTER_CORE) then
- vsv = 0.d0
- vsh = 0.d0
- Qkappa = 3000.d0
- Qmu = 3000.d0
- endif
-
-! non-dimensionalize
-! time scaling (s^{-1}) is done with scaleval
- scaleval=dsqrt(PI*GRAV*RHOAV)
- rho=rho/RHOAV
- vpv=vpv/(R_EARTH*scaleval)
- vph=vph/(R_EARTH*scaleval)
- vsv=vsv/(R_EARTH*scaleval)
- vsh=vsh/(R_EARTH*scaleval)
-
- end subroutine model_ref
-
-!-------------------
-
- subroutine define_model_ref(Mref_V)
-
- implicit none
- include "constants.h"
-
-! 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
-
-
-! define the 1D REF model of Kustowski et al. (2007)
-
- Mref_V%radius_ref( 1 : 30 ) = (/ &
- 0.000000000000000E+000 , &
- 6824.00000000000 , &
- 13648.0000000000 , &
- 20472.0000000000 , &
- 27296.0000000000 , &
- 34120.0000000000 , &
- 40944.0000000000 , &
- 47768.0000000000 , &
- 54592.0000000000 , &
- 61416.0000000000 , &
- 68240.0000000000 , &
- 75064.0000000000 , &
- 81888.0000000000 , &
- 88712.0000000000 , &
- 95536.0000000000 , &
- 102360.000000000 , &
- 109184.000000000 , &
- 116007.000000000 , &
- 122831.000000000 , &
- 129655.000000000 , &
- 136479.000000000 , &
- 143303.000000000 , &
- 150127.000000000 , &
- 156951.000000000 , &
- 163775.000000000 , &
- 170599.000000000 , &
- 177423.000000000 , &
- 184247.000000000 , &
- 191071.000000000 , &
- 197895.000000000 /)
-
- Mref_V%radius_ref( 31 : 60 ) = (/ &
- 204719.000000000 , &
- 211543.000000000 , &
- 218367.000000000 , &
- 225191.000000000 , &
- 232015.000000000 , &
- 238839.000000000 , &
- 245663.000000000 , &
- 252487.000000000 , &
- 259311.000000000 , &
- 266135.000000000 , &
- 272959.000000000 , &
- 279783.000000000 , &
- 286607.000000000 , &
- 293431.000000000 , &
- 300255.000000000 , &
- 307079.000000000 , &
- 313903.000000000 , &
- 320727.000000000 , &
- 327551.000000000 , &
- 334375.000000000 , &
- 341199.000000000 , &
- 348022.000000000 , &
- 354846.000000000 , &
- 361670.000000000 , &
- 368494.000000000 , &
- 375318.000000000 , &
- 382142.000000000 , &
- 388966.000000000 , &
- 395790.000000000 , &
- 402614.000000000 /)
-
- Mref_V%radius_ref( 61 : 90 ) = (/ &
- 409438.000000000 , &
- 416262.000000000 , &
- 423086.000000000 , &
- 429910.000000000 , &
- 436734.000000000 , &
- 443558.000000000 , &
- 450382.000000000 , &
- 457206.000000000 , &
- 464030.000000000 , &
- 470854.000000000 , &
- 477678.000000000 , &
- 484502.000000000 , &
- 491326.000000000 , &
- 498150.000000000 , &
- 504974.000000000 , &
- 511798.000000000 , &
- 518622.000000000 , &
- 525446.000000000 , &
- 532270.000000000 , &
- 539094.000000000 , &
- 545918.000000000 , &
- 552742.000000000 , &
- 559566.000000000 , &
- 566390.000000000 , &
- 573214.000000000 , &
- 580037.000000000 , &
- 586861.000000000 , &
- 593685.000000000 , &
- 600509.000000000 , &
- 607333.000000000 /)
-
- Mref_V%radius_ref( 91 : 120 ) = (/ &
- 614157.000000000 , &
- 620981.000000000 , &
- 627805.000000000 , &
- 634629.000000000 , &
- 641453.000000000 , &
- 648277.000000000 , &
- 655101.000000000 , &
- 661925.000000000 , &
- 668749.000000000 , &
- 675573.000000000 , &
- 682397.000000000 , &
- 689221.000000000 , &
- 696045.000000000 , &
- 702869.000000000 , &
- 709693.000000000 , &
- 716517.000000000 , &
- 723341.000000000 , &
- 730165.000000000 , &
- 736989.000000000 , &
- 743813.000000000 , &
- 750637.000000000 , &
- 757461.000000000 , &
- 764285.000000000 , &
- 771109.000000000 , &
- 777933.000000000 , &
- 784757.000000000 , &
- 791581.000000000 , &
- 798405.000000000 , &
- 805229.000000000 , &
- 812052.000000000 /)
-
- Mref_V%radius_ref( 121 : 150 ) = (/ &
- 818876.000000000 , &
- 825700.000000000 , &
- 832524.000000000 , &
- 839348.000000000 , &
- 846172.000000000 , &
- 852996.000000000 , &
- 859820.000000000 , &
- 866644.000000000 , &
- 873468.000000000 , &
- 880292.000000000 , &
- 887116.000000000 , &
- 893940.000000000 , &
- 900764.000000000 , &
- 907588.000000000 , &
- 914412.000000000 , &
- 921236.000000000 , &
- 928060.000000000 , &
- 934884.000000000 , &
- 941708.000000000 , &
- 948532.000000000 , &
- 955356.000000000 , &
- 962180.000000000 , &
- 969004.000000000 , &
- 975828.000000000 , &
- 982652.000000000 , &
- 989476.000000000 , &
- 996300.000000000 , &
- 1003124.00000000 , &
- 1009948.00000000 , &
- 1016772.00000000 /)
-
- Mref_V%radius_ref( 151 : 180 ) = (/ &
- 1023596.00000000 , &
- 1030420.00000000 , &
- 1037244.00000000 , &
- 1044067.00000000 , &
- 1050891.00000000 , &
- 1057715.00000000 , &
- 1064539.00000000 , &
- 1071363.00000000 , &
- 1078187.00000000 , &
- 1085011.00000000 , &
- 1091835.00000000 , &
- 1098659.00000000 , &
- 1105483.00000000 , &
- 1112307.00000000 , &
- 1119131.00000000 , &
- 1125955.00000000 , &
- 1132779.00000000 , &
- 1139603.00000000 , &
- 1146427.00000000 , &
- 1153251.00000000 , &
- 1160075.00000000 , &
- 1166899.00000000 , &
- 1173723.00000000 , &
- 1180547.00000000 , &
- 1187371.00000000 , &
- 1194195.00000000 , &
- 1201019.00000000 , &
- 1207843.00000000 , &
- 1214667.00000000 , &
- 1221491.00000000 /)
-
- Mref_V%radius_ref( 181 : 210 ) = (/ &
- 1221491.00000000 , &
- 1234250.00000000 , &
- 1247010.00000000 , &
- 1259770.00000000 , &
- 1272530.00000000 , &
- 1285289.00000000 , &
- 1298049.00000000 , &
- 1310809.00000000 , &
- 1323568.00000000 , &
- 1336328.00000000 , &
- 1349088.00000000 , &
- 1361847.00000000 , &
- 1374607.00000000 , &
- 1387367.00000000 , &
- 1400127.00000000 , &
- 1412886.00000000 , &
- 1425646.00000000 , &
- 1438406.00000000 , &
- 1451165.00000000 , &
- 1463925.00000000 , &
- 1476685.00000000 , &
- 1489444.00000000 , &
- 1502204.00000000 , &
- 1514964.00000000 , &
- 1527724.00000000 , &
- 1540483.00000000 , &
- 1553243.00000000 , &
- 1566003.00000000 , &
- 1578762.00000000 , &
- 1591522.00000000 /)
-
- Mref_V%radius_ref( 211 : 240 ) = (/ &
- 1604282.00000000 , &
- 1617041.00000000 , &
- 1629801.00000000 , &
- 1642561.00000000 , &
- 1655321.00000000 , &
- 1668080.00000000 , &
- 1680840.00000000 , &
- 1693600.00000000 , &
- 1706359.00000000 , &
- 1719119.00000000 , &
- 1731879.00000000 , &
- 1744638.00000000 , &
- 1757398.00000000 , &
- 1770158.00000000 , &
- 1782918.00000000 , &
- 1795677.00000000 , &
- 1808437.00000000 , &
- 1821197.00000000 , &
- 1833956.00000000 , &
- 1846716.00000000 , &
- 1859476.00000000 , &
- 1872235.00000000 , &
- 1884995.00000000 , &
- 1897755.00000000 , &
- 1910515.00000000 , &
- 1923274.00000000 , &
- 1936034.00000000 , &
- 1948794.00000000 , &
- 1961553.00000000 , &
- 1974313.00000000 /)
-
- Mref_V%radius_ref( 241 : 270 ) = (/ &
- 1987073.00000000 , &
- 1999832.00000000 , &
- 2012592.00000000 , &
- 2025352.00000000 , &
- 2038112.00000000 , &
- 2050871.00000000 , &
- 2063631.00000000 , &
- 2076391.00000000 , &
- 2089150.00000000 , &
- 2101910.00000000 , &
- 2114670.00000000 , &
- 2127429.00000000 , &
- 2140189.00000000 , &
- 2152949.00000000 , &
- 2165709.00000000 , &
- 2178468.00000000 , &
- 2191228.00000000 , &
- 2203988.00000000 , &
- 2216747.00000000 , &
- 2229507.00000000 , &
- 2242267.00000000 , &
- 2255026.00000000 , &
- 2267786.00000000 , &
- 2280546.00000000 , &
- 2293306.00000000 , &
- 2306065.00000000 , &
- 2318825.00000000 , &
- 2331585.00000000 , &
- 2344344.00000000 , &
- 2357104.00000000 /)
-
- Mref_V%radius_ref( 271 : 300 ) = (/ &
- 2369864.00000000 , &
- 2382623.00000000 , &
- 2395383.00000000 , &
- 2408143.00000000 , &
- 2420903.00000000 , &
- 2433662.00000000 , &
- 2446422.00000000 , &
- 2459182.00000000 , &
- 2471941.00000000 , &
- 2484701.00000000 , &
- 2497461.00000000 , &
- 2510220.00000000 , &
- 2522980.00000000 , &
- 2535740.00000000 , &
- 2548500.00000000 , &
- 2561259.00000000 , &
- 2574019.00000000 , &
- 2586779.00000000 , &
- 2599538.00000000 , &
- 2612298.00000000 , &
- 2625058.00000000 , &
- 2637818.00000000 , &
- 2650577.00000000 , &
- 2663337.00000000 , &
- 2676097.00000000 , &
- 2688856.00000000 , &
- 2701616.00000000 , &
- 2714376.00000000 , &
- 2727135.00000000 , &
- 2739895.00000000 /)
-
- Mref_V%radius_ref( 301 : 330 ) = (/ &
- 2752655.00000000 , &
- 2765415.00000000 , &
- 2778174.00000000 , &
- 2790934.00000000 , &
- 2803694.00000000 , &
- 2816453.00000000 , &
- 2829213.00000000 , &
- 2841973.00000000 , &
- 2854732.00000000 , &
- 2867492.00000000 , &
- 2880252.00000000 , &
- 2893012.00000000 , &
- 2905771.00000000 , &
- 2918531.00000000 , &
- 2931291.00000000 , &
- 2944050.00000000 , &
- 2956810.00000000 , &
- 2969570.00000000 , &
- 2982329.00000000 , &
- 2995089.00000000 , &
- 3007849.00000000 , &
- 3020609.00000000 , &
- 3033368.00000000 , &
- 3046128.00000000 , &
- 3058888.00000000 , &
- 3071647.00000000 , &
- 3084407.00000000 , &
- 3097167.00000000 , &
- 3109926.00000000 , &
- 3122686.00000000 /)
-
- Mref_V%radius_ref( 331 : 360 ) = (/ &
- 3135446.00000000 , &
- 3148206.00000000 , &
- 3160965.00000000 , &
- 3173725.00000000 , &
- 3186485.00000000 , &
- 3199244.00000000 , &
- 3212004.00000000 , &
- 3224764.00000000 , &
- 3237523.00000000 , &
- 3250283.00000000 , &
- 3263043.00000000 , &
- 3275803.00000000 , &
- 3288562.00000000 , &
- 3301322.00000000 , &
- 3314082.00000000 , &
- 3326841.00000000 , &
- 3339601.00000000 , &
- 3352361.00000000 , &
- 3365120.00000000 , &
- 3377880.00000000 , &
- 3390640.00000000 , &
- 3403400.00000000 , &
- 3416159.00000000 , &
- 3428919.00000000 , &
- 3441679.00000000 , &
- 3454438.00000000 , &
- 3467198.00000000 , &
- 3479958.00000000 , &
- 3479958.00000000 , &
- 3489335.00000000 /)
-
- Mref_V%radius_ref( 361 : 390 ) = (/ &
- 3498713.00000000 , &
- 3508091.00000000 , &
- 3517468.00000000 , &
- 3526846.00000000 , &
- 3536224.00000000 , &
- 3545601.00000000 , &
- 3554979.00000000 , &
- 3564357.00000000 , &
- 3573734.00000000 , &
- 3583112.00000000 , &
- 3592489.00000000 , &
- 3601867.00000000 , &
- 3611245.00000000 , &
- 3620622.00000000 , &
- 3630000.00000000 , &
- 3630000.00000000 , &
- 3639471.00000000 , &
- 3648942.00000000 , &
- 3658413.00000000 , &
- 3667885.00000000 , &
- 3677356.00000000 , &
- 3686827.00000000 , &
- 3696298.00000000 , &
- 3705769.00000000 , &
- 3715240.00000000 , &
- 3724712.00000000 , &
- 3734183.00000000 , &
- 3743654.00000000 , &
- 3753125.00000000 , &
- 3762596.00000000 /)
-
- Mref_V%radius_ref( 391 : 420 ) = (/ &
- 3772067.00000000 , &
- 3781538.00000000 , &
- 3791010.00000000 , &
- 3800481.00000000 , &
- 3809952.00000000 , &
- 3819423.00000000 , &
- 3828894.00000000 , &
- 3838365.00000000 , &
- 3847837.00000000 , &
- 3857308.00000000 , &
- 3866779.00000000 , &
- 3876250.00000000 , &
- 3885721.00000000 , &
- 3895192.00000000 , &
- 3904663.00000000 , &
- 3914135.00000000 , &
- 3923606.00000000 , &
- 3933077.00000000 , &
- 3942548.00000000 , &
- 3952019.00000000 , &
- 3961490.00000000 , &
- 3970962.00000000 , &
- 3980433.00000000 , &
- 3989904.00000000 , &
- 3999375.00000000 , &
- 4008846.00000000 , &
- 4018317.00000000 , &
- 4027788.00000000 , &
- 4037260.00000000 , &
- 4046731.00000000 /)
-
- Mref_V%radius_ref( 421 : 450 ) = (/ &
- 4056202.00000000 , &
- 4065673.00000000 , &
- 4075144.00000000 , &
- 4084615.00000000 , &
- 4094087.00000000 , &
- 4103558.00000000 , &
- 4113029.00000000 , &
- 4122500.00000000 , &
- 4131971.00000000 , &
- 4141442.00000000 , &
- 4150913.00000000 , &
- 4160385.00000000 , &
- 4169856.00000000 , &
- 4179327.00000000 , &
- 4188798.00000000 , &
- 4198269.00000000 , &
- 4207740.00000000 , &
- 4217212.00000000 , &
- 4226683.00000000 , &
- 4236154.00000000 , &
- 4245625.00000000 , &
- 4255096.00000000 , &
- 4264567.00000000 , &
- 4274038.00000000 , &
- 4283510.00000000 , &
- 4292981.00000000 , &
- 4302452.00000000 , &
- 4311923.00000000 , &
- 4321394.00000000 , &
- 4330865.00000000 /)
-
- Mref_V%radius_ref( 451 : 480 ) = (/ &
- 4340337.00000000 , &
- 4349808.00000000 , &
- 4359279.00000000 , &
- 4368750.00000000 , &
- 4378221.00000000 , &
- 4387692.00000000 , &
- 4397163.00000000 , &
- 4406635.00000000 , &
- 4416106.00000000 , &
- 4425577.00000000 , &
- 4435048.00000000 , &
- 4444519.00000000 , &
- 4453990.00000000 , &
- 4463462.00000000 , &
- 4472933.00000000 , &
- 4482404.00000000 , &
- 4491875.00000000 , &
- 4501346.00000000 , &
- 4510817.00000000 , &
- 4520288.00000000 , &
- 4529760.00000000 , &
- 4539231.00000000 , &
- 4548702.00000000 , &
- 4558173.00000000 , &
- 4567644.00000000 , &
- 4577115.00000000 , &
- 4586587.00000000 , &
- 4596058.00000000 , &
- 4605529.00000000 , &
- 4615000.00000000 /)
-
- Mref_V%radius_ref( 481 : 510 ) = (/ &
- 4624471.00000000 , &
- 4633942.00000000 , &
- 4643413.00000000 , &
- 4652885.00000000 , &
- 4662356.00000000 , &
- 4671827.00000000 , &
- 4681298.00000000 , &
- 4690769.00000000 , &
- 4700240.00000000 , &
- 4709712.00000000 , &
- 4719183.00000000 , &
- 4728654.00000000 , &
- 4738125.00000000 , &
- 4747596.00000000 , &
- 4757067.00000000 , &
- 4766538.00000000 , &
- 4776010.00000000 , &
- 4785481.00000000 , &
- 4794952.00000000 , &
- 4804423.00000000 , &
- 4813894.00000000 , &
- 4823365.00000000 , &
- 4832837.00000000 , &
- 4842308.00000000 , &
- 4851779.00000000 , &
- 4861250.00000000 , &
- 4870721.00000000 , &
- 4880192.00000000 , &
- 4889663.00000000 , &
- 4899135.00000000 /)
-
- Mref_V%radius_ref( 511 : 540 ) = (/ &
- 4908606.00000000 , &
- 4918077.00000000 , &
- 4927548.00000000 , &
- 4937019.00000000 , &
- 4946490.00000000 , &
- 4955962.00000000 , &
- 4965433.00000000 , &
- 4974904.00000000 , &
- 4984375.00000000 , &
- 4993846.00000000 , &
- 5003317.00000000 , &
- 5012788.00000000 , &
- 5022260.00000000 , &
- 5031731.00000000 , &
- 5041202.00000000 , &
- 5050673.00000000 , &
- 5060144.00000000 , &
- 5069615.00000000 , &
- 5079087.00000000 , &
- 5088558.00000000 , &
- 5098029.00000000 , &
- 5107500.00000000 , &
- 5116971.00000000 , &
- 5126442.00000000 , &
- 5135913.00000000 , &
- 5145385.00000000 , &
- 5154856.00000000 , &
- 5164327.00000000 , &
- 5173798.00000000 , &
- 5183269.00000000 /)
-
- Mref_V%radius_ref( 541 : 570 ) = (/ &
- 5192740.00000000 , &
- 5202212.00000000 , &
- 5211683.00000000 , &
- 5221154.00000000 , &
- 5230625.00000000 , &
- 5240096.00000000 , &
- 5249567.00000000 , &
- 5259038.00000000 , &
- 5268510.00000000 , &
- 5277981.00000000 , &
- 5287452.00000000 , &
- 5296923.00000000 , &
- 5306394.00000000 , &
- 5315865.00000000 , &
- 5325337.00000000 , &
- 5334808.00000000 , &
- 5344279.00000000 , &
- 5353750.00000000 , &
- 5363221.00000000 , &
- 5372692.00000000 , &
- 5382163.00000000 , &
- 5391635.00000000 , &
- 5401106.00000000 , &
- 5410577.00000000 , &
- 5420048.00000000 , &
- 5429519.00000000 , &
- 5438990.00000000 , &
- 5448462.00000000 , &
- 5457933.00000000 , &
- 5467404.00000000 /)
-
- Mref_V%radius_ref( 571 : 600 ) = (/ &
- 5476875.00000000 , &
- 5486346.00000000 , &
- 5495817.00000000 , &
- 5505288.00000000 , &
- 5514760.00000000 , &
- 5524231.00000000 , &
- 5533702.00000000 , &
- 5543173.00000000 , &
- 5552644.00000000 , &
- 5562115.00000000 , &
- 5571587.00000000 , &
- 5581058.00000000 , &
- 5590529.00000000 , &
- 5600000.00000000 , &
- 5600000.00000000 , &
- 5607562.00000000 , &
- 5615125.00000000 , &
- 5622688.00000000 , &
- 5630250.00000000 , &
- 5637812.00000000 , &
- 5645375.00000000 , &
- 5652938.00000000 , &
- 5660500.00000000 , &
- 5668062.00000000 , &
- 5675625.00000000 , &
- 5683188.00000000 , &
- 5690750.00000000 , &
- 5698312.00000000 , &
- 5705875.00000000 , &
- 5713438.00000000 /)
-
- Mref_V%radius_ref( 601 : 630 ) = (/ &
- 5721000.00000000 , &
- 5721000.00000000 , &
- 5724572.00000000 , &
- 5728143.00000000 , &
- 5731714.00000000 , &
- 5735286.00000000 , &
- 5738857.00000000 , &
- 5742428.00000000 , &
- 5746000.00000000 , &
- 5749572.00000000 , &
- 5753143.00000000 , &
- 5756714.00000000 , &
- 5760286.00000000 , &
- 5763857.00000000 , &
- 5767428.00000000 , &
- 5771000.00000000 , &
- 5771000.00000000 , &
- 5777334.00000000 , &
- 5783666.00000000 , &
- 5790000.00000000 , &
- 5796334.00000000 , &
- 5802666.00000000 , &
- 5809000.00000000 , &
- 5815334.00000000 , &
- 5821666.00000000 , &
- 5828000.00000000 , &
- 5834334.00000000 , &
- 5840666.00000000 , &
- 5847000.00000000 , &
- 5853334.00000000 /)
-
- Mref_V%radius_ref( 631 : 660 ) = (/ &
- 5859666.00000000 , &
- 5866000.00000000 , &
- 5872334.00000000 , &
- 5878666.00000000 , &
- 5885000.00000000 , &
- 5891334.00000000 , &
- 5897666.00000000 , &
- 5904000.00000000 , &
- 5910334.00000000 , &
- 5916666.00000000 , &
- 5923000.00000000 , &
- 5929334.00000000 , &
- 5935666.00000000 , &
- 5942000.00000000 , &
- 5948334.00000000 , &
- 5954666.00000000 , &
- 5961000.00000000 , &
- 5961000.00000000 , &
- 5967334.00000000 , &
- 5973666.00000000 , &
- 5980000.00000000 , &
- 5986334.00000000 , &
- 5992666.00000000 , &
- 5999000.00000000 , &
- 6005334.00000000 , &
- 6011666.00000000 , &
- 6018000.00000000 , &
- 6024334.00000000 , &
- 6030666.00000000 , &
- 6037000.00000000 /)
-
- Mref_V%radius_ref( 661 : 690 ) = (/ &
- 6043334.00000000 , &
- 6049666.00000000 , &
- 6056000.00000000 , &
- 6062334.00000000 , &
- 6068666.00000000 , &
- 6075000.00000000 , &
- 6081334.00000000 , &
- 6087666.00000000 , &
- 6094000.00000000 , &
- 6100334.00000000 , &
- 6106666.00000000 , &
- 6113000.00000000 , &
- 6119334.00000000 , &
- 6125666.00000000 , &
- 6132000.00000000 , &
- 6138334.00000000 , &
- 6144666.00000000 , &
- 6151000.00000000 , &
- 6151000.00000000 , &
- 6157087.00000000 , &
- 6163174.00000000 , &
- 6169261.00000000 , &
- 6175348.00000000 , &
- 6181435.00000000 , &
- 6187522.00000000 , &
- 6193609.00000000 , &
- 6199696.00000000 , &
- 6205783.00000000 , &
- 6211870.00000000 , &
- 6217957.00000000 /)
-
- Mref_V%radius_ref( 691 : 720 ) = (/ &
- 6224043.00000000 , &
- 6230130.00000000 , &
- 6236217.00000000 , &
- 6242304.00000000 , &
- 6248391.00000000 , &
- 6254478.00000000 , &
- 6260565.00000000 , &
- 6266652.00000000 , &
- 6272739.00000000 , &
- 6278826.00000000 , &
- 6284913.00000000 , &
- 6291000.00000000 , &
- 6291000.00000000 , &
- 6294971.00000000 , &
- 6298943.00000000 , &
- 6302914.00000000 , &
- 6306886.00000000 , &
- 6310857.00000000 , &
- 6314829.00000000 , &
- 6318800.00000000 , &
- 6322771.00000000 , &
- 6326743.00000000 , &
- 6330714.00000000 , &
- 6334686.00000000 , &
- 6338657.00000000 , &
- 6342629.00000000 , &
- 6346600.00000000 , &
- 6346600.00000000 , &
- 6347540.00000000 , &
- 6348480.00000000 /)
-
- Mref_V%radius_ref( 721 : 750 ) = (/ &
- 6349420.00000000 , &
- 6350360.00000000 , &
- 6351300.00000000 , &
- 6352240.00000000 , &
- 6353180.00000000 , &
- 6354120.00000000 , &
- 6355060.00000000 , &
- 6356000.00000000 , &
- 6356000.00000000 , &
- 6357200.00000000 , &
- 6358400.00000000 , &
- 6359600.00000000 , &
- 6360800.00000000 , &
- 6362000.00000000 , &
- 6363200.00000000 , &
- 6364400.00000000 , &
- 6365600.00000000 , &
- 6366800.00000000 , &
- 6368000.00000000 , &
- 6368000.00000000 , &
- 6368300.00000000 , &
- 6368600.00000000 , &
- 6368900.00000000 , &
- 6369200.00000000 , &
- 6369500.00000000 , &
- 6369800.00000000 , &
- 6370100.00000000 , &
- 6370400.00000000 , &
- 6370700.00000000 , &
- 6371000.00000000 /)
-
- Mref_V%density_ref( 1 : 30 ) = (/ &
- 13088.4800000000 , &
- 13088.4700000000 , &
- 13088.4400000000 , &
- 13088.3900000000 , &
- 13088.3200000000 , &
- 13088.2200000000 , &
- 13088.1100000000 , &
- 13087.9800000000 , &
- 13087.8300000000 , &
- 13087.6600000000 , &
- 13087.4600000000 , &
- 13087.2500000000 , &
- 13087.0200000000 , &
- 13086.7600000000 , &
- 13086.4900000000 , &
- 13086.2000000000 , &
- 13085.8800000000 , &
- 13085.5500000000 , &
- 13085.1900000000 , &
- 13084.8200000000 , &
- 13084.4200000000 , &
- 13084.0100000000 , &
- 13083.5700000000 , &
- 13083.1100000000 , &
- 13082.6400000000 , &
- 13082.1400000000 , &
- 13081.6200000000 , &
- 13081.0900000000 , &
- 13080.5300000000 , &
- 13079.9500000000 /)
-
- Mref_V%density_ref( 31 : 60 ) = (/ &
- 13079.3500000000 , &
- 13078.7300000000 , &
- 13078.0900000000 , &
- 13077.4400000000 , &
- 13076.7600000000 , &
- 13076.0600000000 , &
- 13075.3400000000 , &
- 13074.6000000000 , &
- 13073.8400000000 , &
- 13073.0600000000 , &
- 13072.2500000000 , &
- 13071.4300000000 , &
- 13070.5900000000 , &
- 13069.7300000000 , &
- 13068.8500000000 , &
- 13067.9500000000 , &
- 13067.0200000000 , &
- 13066.0800000000 , &
- 13065.1200000000 , &
- 13064.1300000000 , &
- 13063.1300000000 , &
- 13062.1000000000 , &
- 13061.0600000000 , &
- 13060.0000000000 , &
- 13058.9100000000 , &
- 13057.8100000000 , &
- 13056.6800000000 , &
- 13055.5300000000 , &
- 13054.3700000000 , &
- 13053.1800000000 /)
-
- Mref_V%density_ref( 61 : 90 ) = (/ &
- 13051.9800000000 , &
- 13050.7500000000 , &
- 13049.5000000000 , &
- 13048.2300000000 , &
- 13046.9500000000 , &
- 13045.6400000000 , &
- 13044.3100000000 , &
- 13042.9600000000 , &
- 13041.5900000000 , &
- 13040.2000000000 , &
- 13038.7900000000 , &
- 13037.3600000000 , &
- 13035.9100000000 , &
- 13034.4400000000 , &
- 13032.9500000000 , &
- 13031.4400000000 , &
- 13029.9100000000 , &
- 13028.3600000000 , &
- 13026.7900000000 , &
- 13025.2000000000 , &
- 13023.5800000000 , &
- 13021.9500000000 , &
- 13020.3000000000 , &
- 13018.6300000000 , &
- 13016.9300000000 , &
- 13015.2200000000 , &
- 13013.4900000000 , &
- 13011.7300000000 , &
- 13009.9600000000 , &
- 13008.1600000000 /)
-
- Mref_V%density_ref( 91 : 120 ) = (/ &
- 13006.3500000000 , &
- 13004.5100000000 , &
- 13002.6600000000 , &
- 13000.7800000000 , &
- 12998.8800000000 , &
- 12996.9700000000 , &
- 12995.0300000000 , &
- 12993.0700000000 , &
- 12991.1000000000 , &
- 12989.1000000000 , &
- 12987.0800000000 , &
- 12985.0400000000 , &
- 12982.9900000000 , &
- 12980.9100000000 , &
- 12978.8100000000 , &
- 12976.6900000000 , &
- 12974.5500000000 , &
- 12972.3900000000 , &
- 12970.2100000000 , &
- 12968.0100000000 , &
- 12965.7900000000 , &
- 12963.5500000000 , &
- 12961.2900000000 , &
- 12959.0100000000 , &
- 12956.7000000000 , &
- 12954.3800000000 , &
- 12952.0400000000 , &
- 12949.6800000000 , &
- 12947.2900000000 , &
- 12944.8900000000 /)
-
- Mref_V%density_ref( 121 : 150 ) = (/ &
- 12942.4700000000 , &
- 12940.0200000000 , &
- 12937.5600000000 , &
- 12935.0800000000 , &
- 12932.5700000000 , &
- 12930.0500000000 , &
- 12927.5000000000 , &
- 12924.9400000000 , &
- 12922.3500000000 , &
- 12919.7500000000 , &
- 12917.1200000000 , &
- 12914.4700000000 , &
- 12911.8100000000 , &
- 12909.1200000000 , &
- 12906.4100000000 , &
- 12903.6800000000 , &
- 12900.9400000000 , &
- 12898.1700000000 , &
- 12895.3800000000 , &
- 12892.5700000000 , &
- 12889.7400000000 , &
- 12886.8900000000 , &
- 12884.0200000000 , &
- 12881.1300000000 , &
- 12878.2200000000 , &
- 12875.2900000000 , &
- 12872.3400000000 , &
- 12869.3700000000 , &
- 12866.3800000000 , &
- 12863.3700000000 /)
-
- Mref_V%density_ref( 151 : 180 ) = (/ &
- 12860.3400000000 , &
- 12857.2900000000 , &
- 12854.2100000000 , &
- 12851.1200000000 , &
- 12848.0100000000 , &
- 12844.8800000000 , &
- 12841.7200000000 , &
- 12838.5500000000 , &
- 12835.3500000000 , &
- 12832.1400000000 , &
- 12828.9100000000 , &
- 12825.6500000000 , &
- 12822.3800000000 , &
- 12819.0800000000 , &
- 12815.7600000000 , &
- 12812.4300000000 , &
- 12809.0700000000 , &
- 12805.7000000000 , &
- 12802.3000000000 , &
- 12798.8800000000 , &
- 12795.4400000000 , &
- 12791.9900000000 , &
- 12788.5100000000 , &
- 12785.0100000000 , &
- 12781.4900000000 , &
- 12777.9500000000 , &
- 12774.4000000000 , &
- 12770.8200000000 , &
- 12767.2200000000 , &
- 12763.6000000000 /)
-
- Mref_V%density_ref( 181 : 210 ) = (/ &
- 12166.3500000000 , &
- 12159.7700000000 , &
- 12153.1400000000 , &
- 12146.4500000000 , &
- 12139.7100000000 , &
- 12132.9100000000 , &
- 12126.0500000000 , &
- 12119.1400000000 , &
- 12112.1800000000 , &
- 12105.1500000000 , &
- 12098.0700000000 , &
- 12090.9300000000 , &
- 12083.7300000000 , &
- 12076.4800000000 , &
- 12069.1700000000 , &
- 12061.8000000000 , &
- 12054.3700000000 , &
- 12046.8800000000 , &
- 12039.3300000000 , &
- 12031.7200000000 , &
- 12024.0500000000 , &
- 12016.3300000000 , &
- 12008.5400000000 , &
- 12000.6900000000 , &
- 11992.7800000000 , &
- 11984.8100000000 , &
- 11976.7800000000 , &
- 11968.6800000000 , &
- 11960.5300000000 , &
- 11952.3100000000 /)
-
- Mref_V%density_ref( 211 : 240 ) = (/ &
- 11944.0300000000 , &
- 11935.6900000000 , &
- 11927.2800000000 , &
- 11918.8100000000 , &
- 11910.2800000000 , &
- 11901.6800000000 , &
- 11893.0200000000 , &
- 11884.3000000000 , &
- 11875.5100000000 , &
- 11866.6600000000 , &
- 11857.7400000000 , &
- 11848.7500000000 , &
- 11839.7000000000 , &
- 11830.5800000000 , &
- 11821.4000000000 , &
- 11812.1500000000 , &
- 11802.8400000000 , &
- 11793.4500000000 , &
- 11784.0100000000 , &
- 11774.4900000000 , &
- 11764.9000000000 , &
- 11755.2500000000 , &
- 11745.5300000000 , &
- 11735.7400000000 , &
- 11725.8800000000 , &
- 11715.9500000000 , &
- 11705.9500000000 , &
- 11695.8900000000 , &
- 11685.7500000000 , &
- 11675.5400000000 /)
-
- Mref_V%density_ref( 241 : 270 ) = (/ &
- 11665.2600000000 , &
- 11654.9200000000 , &
- 11644.5000000000 , &
- 11634.0100000000 , &
- 11623.4400000000 , &
- 11612.8100000000 , &
- 11602.1000000000 , &
- 11591.3200000000 , &
- 11580.4700000000 , &
- 11569.5500000000 , &
- 11558.5500000000 , &
- 11547.4800000000 , &
- 11536.3400000000 , &
- 11525.1200000000 , &
- 11513.8300000000 , &
- 11502.4600000000 , &
- 11491.0200000000 , &
- 11479.5100000000 , &
- 11467.9100000000 , &
- 11456.2500000000 , &
- 11444.5000000000 , &
- 11432.6900000000 , &
- 11420.7900000000 , &
- 11408.8200000000 , &
- 11396.7700000000 , &
- 11384.6400000000 , &
- 11372.4400000000 , &
- 11360.1600000000 , &
- 11347.8000000000 , &
- 11335.3700000000 /)
-
- Mref_V%density_ref( 271 : 300 ) = (/ &
- 11322.8500000000 , &
- 11310.2600000000 , &
- 11297.5800000000 , &
- 11284.8300000000 , &
- 11272.0000000000 , &
- 11259.0900000000 , &
- 11246.1000000000 , &
- 11233.0300000000 , &
- 11219.8700000000 , &
- 11206.6400000000 , &
- 11193.3300000000 , &
- 11179.9300000000 , &
- 11166.4500000000 , &
- 11152.8900000000 , &
- 11139.2500000000 , &
- 11125.5300000000 , &
- 11111.7200000000 , &
- 11097.8300000000 , &
- 11083.8600000000 , &
- 11069.8000000000 , &
- 11055.6600000000 , &
- 11041.4400000000 , &
- 11027.1300000000 , &
- 11012.7400000000 , &
- 10998.2600000000 , &
- 10983.7000000000 , &
- 10969.0500000000 , &
- 10954.3200000000 , &
- 10939.5000000000 , &
- 10924.5900000000 /)
-
- Mref_V%density_ref( 301 : 330 ) = (/ &
- 10909.6000000000 , &
- 10894.5200000000 , &
- 10879.3500000000 , &
- 10864.1000000000 , &
- 10848.7600000000 , &
- 10833.3300000000 , &
- 10817.8100000000 , &
- 10802.2100000000 , &
- 10786.5100000000 , &
- 10770.7300000000 , &
- 10754.8600000000 , &
- 10738.9000000000 , &
- 10722.8500000000 , &
- 10706.7100000000 , &
- 10690.4800000000 , &
- 10674.1600000000 , &
- 10657.7500000000 , &
- 10641.2400000000 , &
- 10624.6500000000 , &
- 10607.9600000000 , &
- 10591.1900000000 , &
- 10574.3200000000 , &
- 10557.3600000000 , &
- 10540.3000000000 , &
- 10523.1600000000 , &
- 10505.9200000000 , &
- 10488.5800000000 , &
- 10471.1500000000 , &
- 10453.6300000000 , &
- 10436.0200000000 /)
-
- Mref_V%density_ref( 331 : 360 ) = (/ &
- 10418.3100000000 , &
- 10400.5100000000 , &
- 10382.6100000000 , &
- 10364.6100000000 , &
- 10346.5200000000 , &
- 10328.3400000000 , &
- 10310.0500000000 , &
- 10291.6800000000 , &
- 10273.2000000000 , &
- 10254.6300000000 , &
- 10235.9600000000 , &
- 10217.2000000000 , &
- 10198.3300000000 , &
- 10179.3700000000 , &
- 10160.3100000000 , &
- 10141.1500000000 , &
- 10121.9000000000 , &
- 10102.5400000000 , &
- 10083.0900000000 , &
- 10063.5300000000 , &
- 10043.8800000000 , &
- 10024.1200000000 , &
- 10004.2700000000 , &
- 9984.32000000000 , &
- 9964.26000000000 , &
- 9944.10000000000 , &
- 9923.84000000000 , &
- 9903.48000000000 , &
- 5566.45000000000 , &
- 5561.75000000000 /)
-
- Mref_V%density_ref( 361 : 390 ) = (/ &
- 5557.05000000000 , &
- 5552.36000000000 , &
- 5547.66000000000 , &
- 5542.97000000000 , &
- 5538.28000000000 , &
- 5533.59000000000 , &
- 5528.90000000000 , &
- 5524.21000000000 , &
- 5519.53000000000 , &
- 5514.85000000000 , &
- 5510.16000000000 , &
- 5505.48000000000 , &
- 5500.81000000000 , &
- 5496.13000000000 , &
- 5491.45000000000 , &
- 5491.45000000000 , &
- 5486.73000000000 , &
- 5482.01000000000 , &
- 5477.29000000000 , &
- 5472.57000000000 , &
- 5467.85000000000 , &
- 5463.13000000000 , &
- 5458.42000000000 , &
- 5453.70000000000 , &
- 5448.99000000000 , &
- 5444.27000000000 , &
- 5439.56000000000 , &
- 5434.85000000000 , &
- 5430.13000000000 , &
- 5425.42000000000 /)
-
- Mref_V%density_ref( 391 : 420 ) = (/ &
- 5420.71000000000 , &
- 5416.00000000000 , &
- 5411.29000000000 , &
- 5406.57000000000 , &
- 5401.86000000000 , &
- 5397.15000000000 , &
- 5392.44000000000 , &
- 5387.73000000000 , &
- 5383.02000000000 , &
- 5378.30000000000 , &
- 5373.59000000000 , &
- 5368.88000000000 , &
- 5364.17000000000 , &
- 5359.45000000000 , &
- 5354.74000000000 , &
- 5350.02000000000 , &
- 5345.31000000000 , &
- 5340.59000000000 , &
- 5335.87000000000 , &
- 5331.16000000000 , &
- 5326.44000000000 , &
- 5321.72000000000 , &
- 5317.00000000000 , &
- 5312.28000000000 , &
- 5307.55000000000 , &
- 5302.83000000000 , &
- 5298.10000000000 , &
- 5293.38000000000 , &
- 5288.65000000000 , &
- 5283.92000000000 /)
-
- Mref_V%density_ref( 421 : 450 ) = (/ &
- 5279.19000000000 , &
- 5274.45000000000 , &
- 5269.72000000000 , &
- 5264.98000000000 , &
- 5260.25000000000 , &
- 5255.51000000000 , &
- 5250.77000000000 , &
- 5246.02000000000 , &
- 5241.28000000000 , &
- 5236.53000000000 , &
- 5231.78000000000 , &
- 5227.03000000000 , &
- 5222.27000000000 , &
- 5217.52000000000 , &
- 5212.76000000000 , &
- 5208.00000000000 , &
- 5203.23000000000 , &
- 5198.47000000000 , &
- 5193.70000000000 , &
- 5188.93000000000 , &
- 5184.15000000000 , &
- 5179.38000000000 , &
- 5174.60000000000 , &
- 5169.82000000000 , &
- 5165.03000000000 , &
- 5160.24000000000 , &
- 5155.45000000000 , &
- 5150.65000000000 , &
- 5145.86000000000 , &
- 5141.06000000000 /)
-
- Mref_V%density_ref( 451 : 480 ) = (/ &
- 5136.25000000000 , &
- 5131.44000000000 , &
- 5126.63000000000 , &
- 5121.82000000000 , &
- 5117.00000000000 , &
- 5112.18000000000 , &
- 5107.35000000000 , &
- 5102.52000000000 , &
- 5097.69000000000 , &
- 5092.85000000000 , &
- 5088.01000000000 , &
- 5083.16000000000 , &
- 5078.31000000000 , &
- 5073.46000000000 , &
- 5068.60000000000 , &
- 5063.74000000000 , &
- 5058.87000000000 , &
- 5054.00000000000 , &
- 5049.13000000000 , &
- 5044.25000000000 , &
- 5039.36000000000 , &
- 5034.47000000000 , &
- 5029.58000000000 , &
- 5024.68000000000 , &
- 5019.78000000000 , &
- 5014.87000000000 , &
- 5009.96000000000 , &
- 5005.04000000000 , &
- 5000.12000000000 , &
- 4995.19000000000 /)
-
- Mref_V%density_ref( 481 : 510 ) = (/ &
- 4990.26000000000 , &
- 4985.32000000000 , &
- 4980.38000000000 , &
- 4975.43000000000 , &
- 4970.47000000000 , &
- 4965.51000000000 , &
- 4960.55000000000 , &
- 4955.58000000000 , &
- 4950.60000000000 , &
- 4945.62000000000 , &
- 4940.63000000000 , &
- 4935.64000000000 , &
- 4930.64000000000 , &
- 4925.63000000000 , &
- 4920.62000000000 , &
- 4915.60000000000 , &
- 4910.58000000000 , &
- 4905.55000000000 , &
- 4900.51000000000 , &
- 4895.47000000000 , &
- 4890.42000000000 , &
- 4885.37000000000 , &
- 4880.31000000000 , &
- 4875.24000000000 , &
- 4870.16000000000 , &
- 4865.08000000000 , &
- 4859.99000000000 , &
- 4854.90000000000 , &
- 4849.80000000000 , &
- 4844.69000000000 /)
-
- Mref_V%density_ref( 511 : 540 ) = (/ &
- 4839.57000000000 , &
- 4834.45000000000 , &
- 4829.32000000000 , &
- 4824.18000000000 , &
- 4819.04000000000 , &
- 4813.88000000000 , &
- 4808.73000000000 , &
- 4803.56000000000 , &
- 4798.39000000000 , &
- 4793.20000000000 , &
- 4788.02000000000 , &
- 4782.82000000000 , &
- 4777.61000000000 , &
- 4772.40000000000 , &
- 4767.18000000000 , &
- 4761.95000000000 , &
- 4756.72000000000 , &
- 4751.47000000000 , &
- 4746.22000000000 , &
- 4740.95000000000 , &
- 4735.68000000000 , &
- 4730.40000000000 , &
- 4725.10000000000 , &
- 4719.80000000000 , &
- 4714.48000000000 , &
- 4709.15000000000 , &
- 4703.81000000000 , &
- 4698.44000000000 , &
- 4693.08000000000 , &
- 4687.69000000000 /)
-
- Mref_V%density_ref( 541 : 570 ) = (/ &
- 4682.29000000000 , &
- 4676.87000000000 , &
- 4671.44000000000 , &
- 4665.99000000000 , &
- 4660.52000000000 , &
- 4655.03000000000 , &
- 4649.52000000000 , &
- 4644.00000000000 , &
- 4638.46000000000 , &
- 4632.89000000000 , &
- 4627.31000000000 , &
- 4621.70000000000 , &
- 4616.08000000000 , &
- 4610.44000000000 , &
- 4604.76000000000 , &
- 4599.08000000000 , &
- 4593.36000000000 , &
- 4587.63000000000 , &
- 4581.86000000000 , &
- 4576.07000000000 , &
- 4570.26000000000 , &
- 4564.43000000000 , &
- 4558.56000000000 , &
- 4552.67000000000 , &
- 4546.76000000000 , &
- 4540.82000000000 , &
- 4534.84000000000 , &
- 4528.85000000000 , &
- 4522.81000000000 , &
- 4516.76000000000 /)
-
- Mref_V%density_ref( 571 : 600 ) = (/ &
- 4510.67000000000 , &
- 4504.56000000000 , &
- 4498.41000000000 , &
- 4492.23000000000 , &
- 4486.02000000000 , &
- 4479.78000000000 , &
- 4473.51000000000 , &
- 4467.20000000000 , &
- 4460.87000000000 , &
- 4454.49000000000 , &
- 4448.08000000000 , &
- 4441.63000000000 , &
- 4435.13000000000 , &
- 4428.60000000000 , &
- 4428.59000000000 , &
- 4423.32000000000 , &
- 4418.01000000000 , &
- 4412.67000000000 , &
- 4407.30000000000 , &
- 4401.90000000000 , &
- 4396.45000000000 , &
- 4390.96000000000 , &
- 4385.40000000000 , &
- 4379.81000000000 , &
- 4374.16000000000 , &
- 4368.47000000000 , &
- 4362.72000000000 , &
- 4356.92000000000 , &
- 4351.08000000000 , &
- 4345.18000000000 /)
-
- Mref_V%density_ref( 601 : 630 ) = (/ &
- 4339.24000000000 , &
- 4047.01000000000 , &
- 4042.50000000000 , &
- 4037.98000000000 , &
- 4033.48000000000 , &
- 4028.95000000000 , &
- 4024.45000000000 , &
- 4019.93000000000 , &
- 4015.42000000000 , &
- 4010.90000000000 , &
- 4006.38000000000 , &
- 4001.87000000000 , &
- 3997.35000000000 , &
- 3992.84000000000 , &
- 3988.32000000000 , &
- 3983.80000000000 , &
- 3983.80000000000 , &
- 3975.79000000000 , &
- 3967.77000000000 , &
- 3959.76000000000 , &
- 3951.75000000000 , &
- 3943.73000000000 , &
- 3935.71000000000 , &
- 3927.69000000000 , &
- 3919.67000000000 , &
- 3911.65000000000 , &
- 3903.61000000000 , &
- 3895.58000000000 , &
- 3887.56000000000 , &
- 3879.53000000000 /)
-
- Mref_V%density_ref( 631 : 660 ) = (/ &
- 3871.50000000000 , &
- 3863.46000000000 , &
- 3855.42000000000 , &
- 3847.38000000000 , &
- 3839.33000000000 , &
- 3831.27000000000 , &
- 3823.22000000000 , &
- 3815.16000000000 , &
- 3807.09000000000 , &
- 3799.01000000000 , &
- 3790.94000000000 , &
- 3782.85000000000 , &
- 3774.78000000000 , &
- 3766.66000000000 , &
- 3758.56000000000 , &
- 3750.45000000000 , &
- 3742.34000000000 , &
- 3554.91000000000 , &
- 3551.00000000000 , &
- 3547.07000000000 , &
- 3543.16000000000 , &
- 3539.23000000000 , &
- 3535.32000000000 , &
- 3531.39000000000 , &
- 3527.46000000000 , &
- 3523.57000000000 , &
- 3519.67000000000 , &
- 3515.77000000000 , &
- 3511.91000000000 , &
- 3508.06000000000 /)
-
- Mref_V%density_ref( 661 : 690 ) = (/ &
- 3504.21000000000 , &
- 3500.39000000000 , &
- 3496.58000000000 , &
- 3492.80000000000 , &
- 3489.05000000000 , &
- 3485.32000000000 , &
- 3481.61000000000 , &
- 3477.88000000000 , &
- 3474.16000000000 , &
- 3470.41000000000 , &
- 3466.59000000000 , &
- 3462.74000000000 , &
- 3458.78000000000 , &
- 3454.75000000000 , &
- 3450.61000000000 , &
- 3446.33000000000 , &
- 3441.91000000000 , &
- 3437.35000000000 , &
- 3437.34000000000 , &
- 3432.81000000000 , &
- 3428.15000000000 , &
- 3423.37000000000 , &
- 3418.47000000000 , &
- 3413.47000000000 , &
- 3408.35000000000 , &
- 3403.15000000000 , &
- 3397.87000000000 , &
- 3392.50000000000 , &
- 3387.07000000000 , &
- 3381.58000000000 /)
-
- Mref_V%density_ref( 691 : 720 ) = (/ &
- 3376.03000000000 , &
- 3370.45000000000 , &
- 3364.87000000000 , &
- 3359.31000000000 , &
- 3353.79000000000 , &
- 3348.37000000000 , &
- 3343.03000000000 , &
- 3337.85000000000 , &
- 3332.83000000000 , &
- 3328.01000000000 , &
- 3323.39000000000 , &
- 3319.04000000000 , &
- 3319.03000000000 , &
- 3316.33000000000 , &
- 3313.75000000000 , &
- 3311.30000000000 , &
- 3308.97000000000 , &
- 3306.73000000000 , &
- 3304.58000000000 , &
- 3302.53000000000 , &
- 3300.55000000000 , &
- 3298.63000000000 , &
- 3296.79000000000 , &
- 3295.00000000000 , &
- 3293.25000000000 , &
- 3291.54000000000 , &
- 3289.84000000000 , &
- 2900.00000000000 , &
- 2900.00000000000 , &
- 2900.00000000000 /)
-
- Mref_V%density_ref( 721 : 750 ) = (/ &
- 2900.00000000000 , &
- 2900.00000000000 , &
- 2900.00000000000 , &
- 2900.00000000000 , &
- 2900.00000000000 , &
- 2900.00000000000 , &
- 2900.00000000000 , &
- 2900.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 , &
- 2600.00000000000 /)
-
- Mref_V%vpv_ref( 1 : 30 ) = (/ &
- 11262.2000000000 , &
- 11262.2000000000 , &
- 11262.1800000000 , &
- 11262.1400000000 , &
- 11262.0900000000 , &
- 11262.0200000000 , &
- 11261.9400000000 , &
- 11261.8500000000 , &
- 11261.7400000000 , &
- 11261.6100000000 , &
- 11261.4700000000 , &
- 11261.3200000000 , &
- 11261.1500000000 , &
- 11260.9700000000 , &
- 11260.7700000000 , &
- 11260.5600000000 , &
- 11260.3400000000 , &
- 11260.0900000000 , &
- 11259.8400000000 , &
- 11259.5700000000 , &
- 11259.2800000000 , &
- 11258.9900000000 , &
- 11258.6700000000 , &
- 11258.3400000000 , &
- 11258.0000000000 , &
- 11257.6400000000 , &
- 11257.2700000000 , &
- 11256.8800000000 , &
- 11256.4800000000 , &
- 11256.0600000000 /)
-
- Mref_V%vpv_ref( 31 : 60 ) = (/ &
- 11255.6300000000 , &
- 11255.1900000000 , &
- 11254.7300000000 , &
- 11254.2500000000 , &
- 11253.7600000000 , &
- 11253.2600000000 , &
- 11252.7400000000 , &
- 11252.2100000000 , &
- 11251.6600000000 , &
- 11251.1000000000 , &
- 11250.5200000000 , &
- 11249.9300000000 , &
- 11249.3300000000 , &
- 11248.7100000000 , &
- 11248.0700000000 , &
- 11247.4200000000 , &
- 11246.7600000000 , &
- 11246.0800000000 , &
- 11245.3800000000 , &
- 11244.6700000000 , &
- 11243.9500000000 , &
- 11243.2100000000 , &
- 11242.4600000000 , &
- 11241.7000000000 , &
- 11240.9100000000 , &
- 11240.1200000000 , &
- 11239.3100000000 , &
- 11238.4800000000 , &
- 11237.6400000000 , &
- 11236.7900000000 /)
-
- Mref_V%vpv_ref( 61 : 90 ) = (/ &
- 11235.9200000000 , &
- 11235.0400000000 , &
- 11234.1400000000 , &
- 11233.2300000000 , &
- 11232.3000000000 , &
- 11231.3600000000 , &
- 11230.4000000000 , &
- 11229.4300000000 , &
- 11228.4400000000 , &
- 11227.4400000000 , &
- 11226.4300000000 , &
- 11225.4000000000 , &
- 11224.3600000000 , &
- 11223.3000000000 , &
- 11222.2200000000 , &
- 11221.1400000000 , &
- 11220.0300000000 , &
- 11218.9200000000 , &
- 11217.7800000000 , &
- 11216.6400000000 , &
- 11215.4800000000 , &
- 11214.3000000000 , &
- 11213.1100000000 , &
- 11211.9100000000 , &
- 11210.6900000000 , &
- 11209.4500000000 , &
- 11208.2100000000 , &
- 11206.9400000000 , &
- 11205.6700000000 , &
- 11204.3700000000 /)
-
- Mref_V%vpv_ref( 91 : 120 ) = (/ &
- 11203.0700000000 , &
- 11201.7400000000 , &
- 11200.4100000000 , &
- 11199.0600000000 , &
- 11197.6900000000 , &
- 11196.3100000000 , &
- 11194.9200000000 , &
- 11193.5100000000 , &
- 11192.0900000000 , &
- 11190.6500000000 , &
- 11189.1900000000 , &
- 11187.7300000000 , &
- 11186.2400000000 , &
- 11184.7500000000 , &
- 11183.2400000000 , &
- 11181.7100000000 , &
- 11180.1700000000 , &
- 11178.6100000000 , &
- 11177.0400000000 , &
- 11175.4600000000 , &
- 11173.8600000000 , &
- 11172.2500000000 , &
- 11170.6200000000 , &
- 11168.9800000000 , &
- 11167.3200000000 , &
- 11165.6500000000 , &
- 11163.9600000000 , &
- 11162.2600000000 , &
- 11160.5400000000 , &
- 11158.8100000000 /)
-
- Mref_V%vpv_ref( 121 : 150 ) = (/ &
- 11157.0700000000 , &
- 11155.3100000000 , &
- 11153.5400000000 , &
- 11151.7500000000 , &
- 11149.9400000000 , &
- 11148.1300000000 , &
- 11146.2900000000 , &
- 11144.4500000000 , &
- 11142.5800000000 , &
- 11140.7100000000 , &
- 11138.8200000000 , &
- 11136.9100000000 , &
- 11134.9900000000 , &
- 11133.0600000000 , &
- 11131.1100000000 , &
- 11129.1400000000 , &
- 11127.1600000000 , &
- 11125.1700000000 , &
- 11123.1600000000 , &
- 11121.1400000000 , &
- 11119.1000000000 , &
- 11117.0500000000 , &
- 11114.9900000000 , &
- 11112.9000000000 , &
- 11110.8100000000 , &
- 11108.7000000000 , &
- 11106.5700000000 , &
- 11104.4400000000 , &
- 11102.2800000000 , &
- 11100.1100000000 /)
-
- Mref_V%vpv_ref( 151 : 180 ) = (/ &
- 11097.9300000000 , &
- 11095.7300000000 , &
- 11093.5200000000 , &
- 11091.2900000000 , &
- 11089.0500000000 , &
- 11086.8000000000 , &
- 11084.5300000000 , &
- 11082.2400000000 , &
- 11079.9400000000 , &
- 11077.6300000000 , &
- 11075.3000000000 , &
- 11072.9500000000 , &
- 11070.5900000000 , &
- 11068.2200000000 , &
- 11065.8300000000 , &
- 11063.4300000000 , &
- 11061.0200000000 , &
- 11058.5800000000 , &
- 11056.1400000000 , &
- 11053.6800000000 , &
- 11051.2000000000 , &
- 11048.7100000000 , &
- 11046.2100000000 , &
- 11043.6900000000 , &
- 11041.1600000000 , &
- 11038.6100000000 , &
- 11036.0500000000 , &
- 11033.4700000000 , &
- 11030.8800000000 , &
- 11028.2700000000 /)
-
- Mref_V%vpv_ref( 181 : 210 ) = (/ &
- 10355.6900000000 , &
- 10348.2800000000 , &
- 10340.8500000000 , &
- 10333.3900000000 , &
- 10325.9100000000 , &
- 10318.4000000000 , &
- 10310.8700000000 , &
- 10303.3000000000 , &
- 10295.7100000000 , &
- 10288.0900000000 , &
- 10280.4400000000 , &
- 10272.7600000000 , &
- 10265.0400000000 , &
- 10257.3000000000 , &
- 10249.5200000000 , &
- 10241.7100000000 , &
- 10233.8600000000 , &
- 10225.9800000000 , &
- 10218.0600000000 , &
- 10210.1100000000 , &
- 10202.1200000000 , &
- 10194.1000000000 , &
- 10186.0400000000 , &
- 10177.9400000000 , &
- 10169.7900000000 , &
- 10161.6100000000 , &
- 10153.3900000000 , &
- 10145.1300000000 , &
- 10136.8300000000 , &
- 10128.4800000000 /)
-
- Mref_V%vpv_ref( 211 : 240 ) = (/ &
- 10120.0900000000 , &
- 10111.6600000000 , &
- 10103.1800000000 , &
- 10094.6600000000 , &
- 10086.0900000000 , &
- 10077.4800000000 , &
- 10068.8200000000 , &
- 10060.1100000000 , &
- 10051.3500000000 , &
- 10042.5400000000 , &
- 10033.6900000000 , &
- 10024.7800000000 , &
- 10015.8200000000 , &
- 10006.8200000000 , &
- 9997.75000000000 , &
- 9988.64000000000 , &
- 9979.47000000000 , &
- 9970.25000000000 , &
- 9960.97000000000 , &
- 9951.64000000000 , &
- 9942.25000000000 , &
- 9932.81000000000 , &
- 9923.31000000000 , &
- 9913.75000000000 , &
- 9904.13000000000 , &
- 9894.45000000000 , &
- 9884.71000000000 , &
- 9874.91000000000 , &
- 9865.05000000000 , &
- 9855.13000000000 /)
-
- Mref_V%vpv_ref( 241 : 270 ) = (/ &
- 9845.14000000000 , &
- 9835.09000000000 , &
- 9824.98000000000 , &
- 9814.80000000000 , &
- 9804.56000000000 , &
- 9794.25000000000 , &
- 9783.87000000000 , &
- 9773.43000000000 , &
- 9762.92000000000 , &
- 9752.34000000000 , &
- 9741.69000000000 , &
- 9730.97000000000 , &
- 9720.18000000000 , &
- 9709.32000000000 , &
- 9698.39000000000 , &
- 9687.38000000000 , &
- 9676.31000000000 , &
- 9665.15000000000 , &
- 9653.93000000000 , &
- 9642.63000000000 , &
- 9631.25000000000 , &
- 9619.80000000000 , &
- 9608.27000000000 , &
- 9596.66000000000 , &
- 9584.97000000000 , &
- 9573.20000000000 , &
- 9561.36000000000 , &
- 9549.43000000000 , &
- 9537.43000000000 , &
- 9525.34000000000 /)
-
- Mref_V%vpv_ref( 271 : 300 ) = (/ &
- 9513.17000000000 , &
- 9500.91000000000 , &
- 9488.57000000000 , &
- 9476.15000000000 , &
- 9463.64000000000 , &
- 9451.05000000000 , &
- 9438.37000000000 , &
- 9425.61000000000 , &
- 9412.75000000000 , &
- 9399.81000000000 , &
- 9386.78000000000 , &
- 9373.66000000000 , &
- 9360.45000000000 , &
- 9347.15000000000 , &
- 9333.76000000000 , &
- 9320.27000000000 , &
- 9306.70000000000 , &
- 9293.03000000000 , &
- 9279.26000000000 , &
- 9265.40000000000 , &
- 9251.45000000000 , &
- 9237.40000000000 , &
- 9223.25000000000 , &
- 9209.00000000000 , &
- 9194.66000000000 , &
- 9180.22000000000 , &
- 9165.68000000000 , &
- 9151.03000000000 , &
- 9136.29000000000 , &
- 9121.45000000000 /)
-
- Mref_V%vpv_ref( 301 : 330 ) = (/ &
- 9106.50000000000 , &
- 9091.46000000000 , &
- 9076.30000000000 , &
- 9061.05000000000 , &
- 9045.69000000000 , &
- 9030.23000000000 , &
- 9014.65000000000 , &
- 8998.98000000000 , &
- 8983.19000000000 , &
- 8967.30000000000 , &
- 8951.30000000000 , &
- 8935.19000000000 , &
- 8918.97000000000 , &
- 8902.64000000000 , &
- 8886.20000000000 , &
- 8869.64000000000 , &
- 8852.98000000000 , &
- 8836.20000000000 , &
- 8819.31000000000 , &
- 8802.30000000000 , &
- 8785.18000000000 , &
- 8767.94000000000 , &
- 8750.59000000000 , &
- 8733.12000000000 , &
- 8715.53000000000 , &
- 8697.82000000000 , &
- 8680.00000000000 , &
- 8662.05000000000 , &
- 8643.99000000000 , &
- 8625.80000000000 /)
-
- Mref_V%vpv_ref( 331 : 360 ) = (/ &
- 8607.49000000000 , &
- 8589.06000000000 , &
- 8570.51000000000 , &
- 8551.83000000000 , &
- 8533.03000000000 , &
- 8514.10000000000 , &
- 8495.05000000000 , &
- 8475.87000000000 , &
- 8456.57000000000 , &
- 8437.14000000000 , &
- 8417.58000000000 , &
- 8397.89000000000 , &
- 8378.07000000000 , &
- 8358.12000000000 , &
- 8338.04000000000 , &
- 8317.83000000000 , &
- 8297.49000000000 , &
- 8277.01000000000 , &
- 8256.41000000000 , &
- 8235.66000000000 , &
- 8214.79000000000 , &
- 8193.77000000000 , &
- 8172.62000000000 , &
- 8151.34000000000 , &
- 8129.92000000000 , &
- 8108.36000000000 , &
- 8086.66000000000 , &
- 8064.82000000000 , &
- 13716.6000000000 , &
- 13714.2900000000 /)
-
- Mref_V%vpv_ref( 361 : 390 ) = (/ &
- 13712.0000000000 , &
- 13709.7000000000 , &
- 13707.4200000000 , &
- 13705.1400000000 , &
- 13702.8600000000 , &
- 13700.5900000000 , &
- 13698.3300000000 , &
- 13696.0700000000 , &
- 13693.8200000000 , &
- 13691.5700000000 , &
- 13689.3300000000 , &
- 13687.0900000000 , &
- 13684.8600000000 , &
- 13682.6300000000 , &
- 13680.4100000000 , &
- 13680.4100000000 , &
- 13668.9000000000 , &
- 13657.4300000000 , &
- 13645.9700000000 , &
- 13634.5400000000 , &
- 13623.1400000000 , &
- 13611.7600000000 , &
- 13600.4000000000 , &
- 13589.0700000000 , &
- 13577.7600000000 , &
- 13566.4700000000 , &
- 13555.2000000000 , &
- 13543.9500000000 , &
- 13532.7200000000 , &
- 13521.5100000000 /)
-
- Mref_V%vpv_ref( 391 : 420 ) = (/ &
- 13510.3200000000 , &
- 13499.1400000000 , &
- 13487.9900000000 , &
- 13476.8500000000 , &
- 13465.7300000000 , &
- 13454.6300000000 , &
- 13443.5400000000 , &
- 13432.4600000000 , &
- 13421.4100000000 , &
- 13410.3600000000 , &
- 13399.3300000000 , &
- 13388.3100000000 , &
- 13377.3100000000 , &
- 13366.3100000000 , &
- 13355.3300000000 , &
- 13344.3600000000 , &
- 13333.4000000000 , &
- 13322.4500000000 , &
- 13311.5100000000 , &
- 13300.5800000000 , &
- 13289.6600000000 , &
- 13278.7400000000 , &
- 13267.8400000000 , &
- 13256.9300000000 , &
- 13246.0400000000 , &
- 13235.1500000000 , &
- 13224.2700000000 , &
- 13213.3900000000 , &
- 13202.5100000000 , &
- 13191.6400000000 /)
-
- Mref_V%vpv_ref( 421 : 450 ) = (/ &
- 13180.7800000000 , &
- 13169.9100000000 , &
- 13159.0500000000 , &
- 13148.1900000000 , &
- 13137.3300000000 , &
- 13126.4700000000 , &
- 13115.6100000000 , &
- 13104.7500000000 , &
- 13093.8900000000 , &
- 13083.0200000000 , &
- 13072.1600000000 , &
- 13061.2900000000 , &
- 13050.4200000000 , &
- 13039.5500000000 , &
- 13028.6700000000 , &
- 13017.7800000000 , &
- 13006.9000000000 , &
- 12996.0000000000 , &
- 12985.1000000000 , &
- 12974.1900000000 , &
- 12963.2800000000 , &
- 12952.3600000000 , &
- 12941.4200000000 , &
- 12930.4800000000 , &
- 12919.5400000000 , &
- 12908.5800000000 , &
- 12897.6100000000 , &
- 12886.6300000000 , &
- 12875.6300000000 , &
- 12864.6300000000 /)
-
- Mref_V%vpv_ref( 451 : 480 ) = (/ &
- 12853.6100000000 , &
- 12842.5800000000 , &
- 12831.5400000000 , &
- 12820.4800000000 , &
- 12809.4100000000 , &
- 12798.3200000000 , &
- 12787.2200000000 , &
- 12776.1000000000 , &
- 12764.9600000000 , &
- 12753.8100000000 , &
- 12742.6300000000 , &
- 12731.4400000000 , &
- 12720.2400000000 , &
- 12709.0100000000 , &
- 12697.7600000000 , &
- 12686.4900000000 , &
- 12675.2000000000 , &
- 12663.8900000000 , &
- 12652.5600000000 , &
- 12641.2000000000 , &
- 12629.8200000000 , &
- 12618.4200000000 , &
- 12606.9900000000 , &
- 12595.5400000000 , &
- 12584.0600000000 , &
- 12572.5600000000 , &
- 12561.0300000000 , &
- 12549.4800000000 , &
- 12537.8900000000 , &
- 12526.2800000000 /)
-
- Mref_V%vpv_ref( 481 : 510 ) = (/ &
- 12514.6400000000 , &
- 12502.9800000000 , &
- 12491.2800000000 , &
- 12479.5500000000 , &
- 12467.7900000000 , &
- 12456.0100000000 , &
- 12444.1900000000 , &
- 12432.3300000000 , &
- 12420.4500000000 , &
- 12408.5300000000 , &
- 12396.5800000000 , &
- 12384.6000000000 , &
- 12372.5800000000 , &
- 12360.5200000000 , &
- 12348.4300000000 , &
- 12336.3000000000 , &
- 12324.1400000000 , &
- 12311.9400000000 , &
- 12299.7000000000 , &
- 12287.4200000000 , &
- 12275.1100000000 , &
- 12262.7500000000 , &
- 12250.3500000000 , &
- 12237.9200000000 , &
- 12225.4400000000 , &
- 12212.9200000000 , &
- 12200.3600000000 , &
- 12187.7600000000 , &
- 12175.1100000000 , &
- 12162.4300000000 /)
-
- Mref_V%vpv_ref( 511 : 540 ) = (/ &
- 12149.6900000000 , &
- 12136.9100000000 , &
- 12124.0900000000 , &
- 12111.2200000000 , &
- 12098.3100000000 , &
- 12085.3400000000 , &
- 12072.3400000000 , &
- 12059.2800000000 , &
- 12046.1700000000 , &
- 12033.0200000000 , &
- 12019.8200000000 , &
- 12006.5600000000 , &
- 11993.2600000000 , &
- 11979.9000000000 , &
- 11966.5000000000 , &
- 11953.0400000000 , &
- 11939.5300000000 , &
- 11925.9700000000 , &
- 11912.3500000000 , &
- 11898.6900000000 , &
- 11884.9600000000 , &
- 11871.1900000000 , &
- 11857.3700000000 , &
- 11843.4800000000 , &
- 11829.5500000000 , &
- 11815.5700000000 , &
- 11801.5300000000 , &
- 11787.4400000000 , &
- 11773.3000000000 , &
- 11759.1000000000 /)
-
- Mref_V%vpv_ref( 541 : 570 ) = (/ &
- 11744.8500000000 , &
- 11730.5500000000 , &
- 11716.1800000000 , &
- 11701.7800000000 , &
- 11687.3100000000 , &
- 11672.8000000000 , &
- 11658.2300000000 , &
- 11643.6000000000 , &
- 11628.9200000000 , &
- 11614.1900000000 , &
- 11599.4000000000 , &
- 11584.5700000000 , &
- 11569.6800000000 , &
- 11554.7200000000 , &
- 11539.7200000000 , &
- 11524.6700000000 , &
- 11509.5600000000 , &
- 11494.3900000000 , &
- 11479.1700000000 , &
- 11463.8900000000 , &
- 11448.5500000000 , &
- 11433.1700000000 , &
- 11417.7300000000 , &
- 11402.2300000000 , &
- 11386.6800000000 , &
- 11371.0700000000 , &
- 11355.4100000000 , &
- 11339.6900000000 , &
- 11323.9100000000 , &
- 11308.0900000000 /)
-
- Mref_V%vpv_ref( 571 : 600 ) = (/ &
- 11292.2000000000 , &
- 11276.2500000000 , &
- 11260.2500000000 , &
- 11244.1900000000 , &
- 11228.0800000000 , &
- 11211.9000000000 , &
- 11195.6700000000 , &
- 11179.3800000000 , &
- 11163.0400000000 , &
- 11146.6300000000 , &
- 11130.1800000000 , &
- 11113.6700000000 , &
- 11097.1100000000 , &
- 11080.5100000000 , &
- 11080.5100000000 , &
- 11063.0100000000 , &
- 11045.2200000000 , &
- 11026.8200000000 , &
- 11008.4700000000 , &
- 10989.0400000000 , &
- 10969.6300000000 , &
- 10948.7600000000 , &
- 10928.0200000000 , &
- 10907.4200000000 , &
- 10886.9400000000 , &
- 10866.6000000000 , &
- 10846.4100000000 , &
- 10826.3500000000 , &
- 10806.4200000000 , &
- 10786.6100000000 /)
-
- Mref_V%vpv_ref( 601 : 630 ) = (/ &
- 10766.9000000000 , &
- 10278.8800000000 , &
- 10261.8700000000 , &
- 10244.8400000000 , &
- 10227.8200000000 , &
- 10210.8000000000 , &
- 10193.7800000000 , &
- 10176.7700000000 , &
- 10159.7400000000 , &
- 10142.7200000000 , &
- 10125.7100000000 , &
- 10108.7000000000 , &
- 10091.6800000000 , &
- 10074.6800000000 , &
- 10057.6800000000 , &
- 10040.6400000000 , &
- 10040.6700000000 , &
- 10010.5200000000 , &
- 9980.51000000000 , &
- 9950.64000000000 , &
- 9920.91000000000 , &
- 9891.35000000000 , &
- 9861.96000000000 , &
- 9832.79000000000 , &
- 9803.79000000000 , &
- 9774.98000000000 , &
- 9746.41000000000 , &
- 9718.08000000000 , &
- 9689.96000000000 , &
- 9662.10000000000 /)
-
- Mref_V%vpv_ref( 631 : 660 ) = (/ &
- 9634.47000000000 , &
- 9607.11000000000 , &
- 9579.97000000000 , &
- 9553.08000000000 , &
- 9526.38000000000 , &
- 9499.78000000000 , &
- 9473.25000000000 , &
- 9446.74000000000 , &
- 9420.19000000000 , &
- 9393.55000000000 , &
- 9366.75000000000 , &
- 9339.76000000000 , &
- 9312.50000000000 , &
- 9284.96000000000 , &
- 9257.04000000000 , &
- 9228.73000000000 , &
- 9199.94000000000 , &
- 8940.94000000000 , &
- 8930.61000000000 , &
- 8920.22000000000 , &
- 8909.68000000000 , &
- 8898.47000000000 , &
- 8886.28000000000 , &
- 8873.03000000000 , &
- 8858.58000000000 , &
- 8842.82000000000 , &
- 8825.64000000000 , &
- 8806.94000000000 , &
- 8786.67000000000 , &
- 8764.85000000000 /)
-
- Mref_V%vpv_ref( 661 : 690 ) = (/ &
- 8741.49000000000 , &
- 8716.63000000000 , &
- 8690.30000000000 , &
- 8662.50000000000 , &
- 8633.28000000000 , &
- 8602.66000000000 , &
- 8570.81000000000 , &
- 8538.06000000000 , &
- 8504.66000000000 , &
- 8470.92000000000 , &
- 8437.13000000000 , &
- 8403.52000000000 , &
- 8370.42000000000 , &
- 8338.11000000000 , &
- 8306.25000000000 , &
- 8275.42000000000 , &
- 8241.77000000000 , &
- 8207.37000000000 , &
- 8207.01000000000 , &
- 8174.32000000000 , &
- 8141.99000000000 , &
- 8110.40000000000 , &
- 8079.71000000000 , &
- 8050.15000000000 , &
- 8021.89000000000 , &
- 7995.08000000000 , &
- 7969.97000000000 , &
- 7946.70000000000 , &
- 7925.45000000000 , &
- 7906.44000000000 /)
-
- Mref_V%vpv_ref( 691 : 720 ) = (/ &
- 7889.80000000000 , &
- 7875.56000000000 , &
- 7863.64000000000 , &
- 7853.87000000000 , &
- 7846.17000000000 , &
- 7840.38000000000 , &
- 7836.39000000000 , &
- 7834.11000000000 , &
- 7833.38000000000 , &
- 7834.11000000000 , &
- 7836.11000000000 , &
- 7839.12000000000 , &
- 7839.37000000000 , &
- 7841.82000000000 , &
- 7844.77000000000 , &
- 7848.07000000000 , &
- 7851.72000000000 , &
- 7855.75000000000 , &
- 7860.14000000000 , &
- 7864.89000000000 , &
- 7870.01000000000 , &
- 7875.49000000000 , &
- 7881.33000000000 , &
- 7887.54000000000 , &
- 7894.13000000000 , &
- 7901.10000000000 , &
- 7908.24000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 /)
-
- Mref_V%vpv_ref( 721 : 750 ) = (/ &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 /)
-
- Mref_V%vsv_ref( 1 : 30 ) = (/ &
- 3667.80000000000 , &
- 3667.79000000000 , &
- 3667.78000000000 , &
- 3667.75000000000 , &
- 3667.72000000000 , &
- 3667.67000000000 , &
- 3667.62000000000 , &
- 3667.55000000000 , &
- 3667.47000000000 , &
- 3667.39000000000 , &
- 3667.29000000000 , &
- 3667.18000000000 , &
- 3667.06000000000 , &
- 3666.94000000000 , &
- 3666.80000000000 , &
- 3666.65000000000 , &
- 3666.49000000000 , &
- 3666.32000000000 , &
- 3666.15000000000 , &
- 3665.96000000000 , &
- 3665.76000000000 , &
- 3665.55000000000 , &
- 3665.33000000000 , &
- 3665.10000000000 , &
- 3664.86000000000 , &
- 3664.61000000000 , &
- 3664.35000000000 , &
- 3664.08000000000 , &
- 3663.80000000000 , &
- 3663.51000000000 /)
-
- Mref_V%vsv_ref( 31 : 60 ) = (/ &
- 3663.21000000000 , &
- 3662.90000000000 , &
- 3662.57000000000 , &
- 3662.24000000000 , &
- 3661.90000000000 , &
- 3661.55000000000 , &
- 3661.19000000000 , &
- 3660.81000000000 , &
- 3660.43000000000 , &
- 3660.04000000000 , &
- 3659.64000000000 , &
- 3659.22000000000 , &
- 3658.80000000000 , &
- 3658.36000000000 , &
- 3657.92000000000 , &
- 3657.47000000000 , &
- 3657.00000000000 , &
- 3656.53000000000 , &
- 3656.04000000000 , &
- 3655.55000000000 , &
- 3655.04000000000 , &
- 3654.53000000000 , &
- 3654.00000000000 , &
- 3653.47000000000 , &
- 3652.92000000000 , &
- 3652.36000000000 , &
- 3651.80000000000 , &
- 3651.22000000000 , &
- 3650.63000000000 , &
- 3650.04000000000 /)
-
- Mref_V%vsv_ref( 61 : 90 ) = (/ &
- 3649.43000000000 , &
- 3648.81000000000 , &
- 3648.19000000000 , &
- 3647.55000000000 , &
- 3646.90000000000 , &
- 3646.24000000000 , &
- 3645.57000000000 , &
- 3644.89000000000 , &
- 3644.21000000000 , &
- 3643.51000000000 , &
- 3642.80000000000 , &
- 3642.08000000000 , &
- 3641.35000000000 , &
- 3640.61000000000 , &
- 3639.86000000000 , &
- 3639.10000000000 , &
- 3638.33000000000 , &
- 3637.55000000000 , &
- 3636.76000000000 , &
- 3635.96000000000 , &
- 3635.14000000000 , &
- 3634.32000000000 , &
- 3633.49000000000 , &
- 3632.65000000000 , &
- 3631.80000000000 , &
- 3630.93000000000 , &
- 3630.06000000000 , &
- 3629.18000000000 , &
- 3628.29000000000 , &
- 3627.38000000000 /)
-
- Mref_V%vsv_ref( 91 : 120 ) = (/ &
- 3626.47000000000 , &
- 3625.55000000000 , &
- 3624.61000000000 , &
- 3623.67000000000 , &
- 3622.71000000000 , &
- 3621.75000000000 , &
- 3620.78000000000 , &
- 3619.79000000000 , &
- 3618.80000000000 , &
- 3617.79000000000 , &
- 3616.78000000000 , &
- 3615.75000000000 , &
- 3614.71000000000 , &
- 3613.67000000000 , &
- 3612.61000000000 , &
- 3611.55000000000 , &
- 3610.47000000000 , &
- 3609.38000000000 , &
- 3608.28000000000 , &
- 3607.18000000000 , &
- 3606.06000000000 , &
- 3604.93000000000 , &
- 3603.79000000000 , &
- 3602.65000000000 , &
- 3601.49000000000 , &
- 3600.32000000000 , &
- 3599.14000000000 , &
- 3597.95000000000 , &
- 3596.75000000000 , &
- 3595.54000000000 /)
-
- Mref_V%vsv_ref( 121 : 150 ) = (/ &
- 3594.32000000000 , &
- 3593.10000000000 , &
- 3591.86000000000 , &
- 3590.61000000000 , &
- 3589.34000000000 , &
- 3588.07000000000 , &
- 3586.79000000000 , &
- 3585.50000000000 , &
- 3584.20000000000 , &
- 3582.89000000000 , &
- 3581.57000000000 , &
- 3580.24000000000 , &
- 3578.90000000000 , &
- 3577.54000000000 , &
- 3576.18000000000 , &
- 3574.81000000000 , &
- 3573.43000000000 , &
- 3572.03000000000 , &
- 3570.63000000000 , &
- 3569.22000000000 , &
- 3567.79000000000 , &
- 3566.36000000000 , &
- 3564.91000000000 , &
- 3563.46000000000 , &
- 3562.00000000000 , &
- 3560.52000000000 , &
- 3559.04000000000 , &
- 3557.54000000000 , &
- 3556.04000000000 , &
- 3554.52000000000 /)
-
- Mref_V%vsv_ref( 151 : 180 ) = (/ &
- 3553.00000000000 , &
- 3551.46000000000 , &
- 3549.91000000000 , &
- 3548.36000000000 , &
- 3546.79000000000 , &
- 3545.21000000000 , &
- 3543.63000000000 , &
- 3542.03000000000 , &
- 3540.42000000000 , &
- 3538.81000000000 , &
- 3537.18000000000 , &
- 3535.54000000000 , &
- 3533.89000000000 , &
- 3532.23000000000 , &
- 3530.57000000000 , &
- 3528.89000000000 , &
- 3527.20000000000 , &
- 3525.50000000000 , &
- 3523.79000000000 , &
- 3522.07000000000 , &
- 3520.34000000000 , &
- 3518.60000000000 , &
- 3516.85000000000 , &
- 3515.09000000000 , &
- 3513.32000000000 , &
- 3511.54000000000 , &
- 3509.75000000000 , &
- 3507.95000000000 , &
- 3506.13000000000 , &
- 3504.31000000000 /)
-
- Mref_V%vsv_ref( 181 : 210 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%vsv_ref( 211 : 240 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%vsv_ref( 241 : 270 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%vsv_ref( 271 : 300 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%vsv_ref( 301 : 330 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%vsv_ref( 331 : 360 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 7264.66000000000 , &
- 7264.75000000000 /)
-
- Mref_V%vsv_ref( 361 : 390 ) = (/ &
- 7264.85000000000 , &
- 7264.94000000000 , &
- 7265.03000000000 , &
- 7265.12000000000 , &
- 7265.21000000000 , &
- 7265.29000000000 , &
- 7265.38000000000 , &
- 7265.46000000000 , &
- 7265.54000000000 , &
- 7265.62000000000 , &
- 7265.69000000000 , &
- 7265.76000000000 , &
- 7265.84000000000 , &
- 7265.91000000000 , &
- 7265.97000000000 , &
- 7265.97000000000 , &
- 7261.63000000000 , &
- 7257.29000000000 , &
- 7252.97000000000 , &
- 7248.64000000000 , &
- 7244.33000000000 , &
- 7240.01000000000 , &
- 7235.71000000000 , &
- 7231.41000000000 , &
- 7227.12000000000 , &
- 7222.83000000000 , &
- 7218.55000000000 , &
- 7214.27000000000 , &
- 7210.00000000000 , &
- 7205.73000000000 /)
-
- Mref_V%vsv_ref( 391 : 420 ) = (/ &
- 7201.47000000000 , &
- 7197.21000000000 , &
- 7192.95000000000 , &
- 7188.70000000000 , &
- 7184.45000000000 , &
- 7180.21000000000 , &
- 7175.97000000000 , &
- 7171.73000000000 , &
- 7167.50000000000 , &
- 7163.27000000000 , &
- 7159.04000000000 , &
- 7154.81000000000 , &
- 7150.59000000000 , &
- 7146.37000000000 , &
- 7142.15000000000 , &
- 7137.93000000000 , &
- 7133.71000000000 , &
- 7129.50000000000 , &
- 7125.29000000000 , &
- 7121.07000000000 , &
- 7116.86000000000 , &
- 7112.65000000000 , &
- 7108.44000000000 , &
- 7104.23000000000 , &
- 7100.02000000000 , &
- 7095.81000000000 , &
- 7091.60000000000 , &
- 7087.39000000000 , &
- 7083.18000000000 , &
- 7078.96000000000 /)
-
- Mref_V%vsv_ref( 421 : 450 ) = (/ &
- 7074.75000000000 , &
- 7070.54000000000 , &
- 7066.32000000000 , &
- 7062.10000000000 , &
- 7057.88000000000 , &
- 7053.66000000000 , &
- 7049.44000000000 , &
- 7045.22000000000 , &
- 7040.99000000000 , &
- 7036.76000000000 , &
- 7032.52000000000 , &
- 7028.29000000000 , &
- 7024.05000000000 , &
- 7019.81000000000 , &
- 7015.56000000000 , &
- 7011.31000000000 , &
- 7007.06000000000 , &
- 7002.80000000000 , &
- 6998.54000000000 , &
- 6994.27000000000 , &
- 6990.00000000000 , &
- 6985.72000000000 , &
- 6981.44000000000 , &
- 6977.15000000000 , &
- 6972.86000000000 , &
- 6968.57000000000 , &
- 6964.26000000000 , &
- 6959.95000000000 , &
- 6955.64000000000 , &
- 6951.32000000000 /)
-
- Mref_V%vsv_ref( 451 : 480 ) = (/ &
- 6946.99000000000 , &
- 6942.66000000000 , &
- 6938.31000000000 , &
- 6933.97000000000 , &
- 6929.61000000000 , &
- 6925.25000000000 , &
- 6920.88000000000 , &
- 6916.50000000000 , &
- 6912.11000000000 , &
- 6907.72000000000 , &
- 6903.32000000000 , &
- 6898.91000000000 , &
- 6894.49000000000 , &
- 6890.06000000000 , &
- 6885.62000000000 , &
- 6881.17000000000 , &
- 6876.72000000000 , &
- 6872.25000000000 , &
- 6867.78000000000 , &
- 6863.29000000000 , &
- 6858.80000000000 , &
- 6854.29000000000 , &
- 6849.78000000000 , &
- 6845.25000000000 , &
- 6840.71000000000 , &
- 6836.16000000000 , &
- 6831.60000000000 , &
- 6827.03000000000 , &
- 6822.45000000000 , &
- 6817.85000000000 /)
-
- Mref_V%vsv_ref( 481 : 510 ) = (/ &
- 6813.25000000000 , &
- 6808.63000000000 , &
- 6804.00000000000 , &
- 6799.35000000000 , &
- 6794.70000000000 , &
- 6790.03000000000 , &
- 6785.34000000000 , &
- 6780.65000000000 , &
- 6775.94000000000 , &
- 6771.22000000000 , &
- 6766.48000000000 , &
- 6761.73000000000 , &
- 6756.97000000000 , &
- 6752.19000000000 , &
- 6747.40000000000 , &
- 6742.59000000000 , &
- 6737.76000000000 , &
- 6732.93000000000 , &
- 6728.07000000000 , &
- 6723.21000000000 , &
- 6718.32000000000 , &
- 6713.42000000000 , &
- 6708.51000000000 , &
- 6703.57000000000 , &
- 6698.62000000000 , &
- 6693.66000000000 , &
- 6688.68000000000 , &
- 6683.68000000000 , &
- 6678.66000000000 , &
- 6673.63000000000 /)
-
- Mref_V%vsv_ref( 511 : 540 ) = (/ &
- 6668.58000000000 , &
- 6663.51000000000 , &
- 6658.43000000000 , &
- 6653.32000000000 , &
- 6648.20000000000 , &
- 6643.06000000000 , &
- 6637.90000000000 , &
- 6632.73000000000 , &
- 6627.53000000000 , &
- 6622.31000000000 , &
- 6617.08000000000 , &
- 6611.82000000000 , &
- 6606.55000000000 , &
- 6601.26000000000 , &
- 6595.94000000000 , &
- 6590.61000000000 , &
- 6584.91000000000 , &
- 6579.51000000000 , &
- 6574.11000000000 , &
- 6568.67000000000 , &
- 6563.22000000000 , &
- 6557.74000000000 , &
- 6552.24000000000 , &
- 6546.73000000000 , &
- 6541.19000000000 , &
- 6535.63000000000 , &
- 6530.05000000000 , &
- 6524.44000000000 , &
- 6518.82000000000 , &
- 6513.17000000000 /)
-
- Mref_V%vsv_ref( 541 : 570 ) = (/ &
- 6507.50000000000 , &
- 6501.80000000000 , &
- 6496.09000000000 , &
- 6490.35000000000 , &
- 6484.59000000000 , &
- 6478.80000000000 , &
- 6472.99000000000 , &
- 6467.16000000000 , &
- 6461.30000000000 , &
- 6455.42000000000 , &
- 6449.51000000000 , &
- 6443.58000000000 , &
- 6437.63000000000 , &
- 6431.65000000000 , &
- 6425.65000000000 , &
- 6419.61000000000 , &
- 6413.56000000000 , &
- 6407.48000000000 , &
- 6401.37000000000 , &
- 6395.25000000000 , &
- 6389.09000000000 , &
- 6382.91000000000 , &
- 6376.70000000000 , &
- 6370.46000000000 , &
- 6364.20000000000 , &
- 6357.91000000000 , &
- 6351.59000000000 , &
- 6345.25000000000 , &
- 6338.88000000000 , &
- 6332.49000000000 /)
-
- Mref_V%vsv_ref( 571 : 600 ) = (/ &
- 6326.05000000000 , &
- 6319.60000000000 , &
- 6313.13000000000 , &
- 6306.62000000000 , &
- 6300.08000000000 , &
- 6293.52000000000 , &
- 6286.92000000000 , &
- 6280.29000000000 , &
- 6273.64000000000 , &
- 6266.96000000000 , &
- 6260.25000000000 , &
- 6253.51000000000 , &
- 6246.75000000000 , &
- 6239.95000000000 , &
- 6239.95000000000 , &
- 6219.68000000000 , &
- 6200.29000000000 , &
- 6181.16000000000 , &
- 6162.04000000000 , &
- 6143.01000000000 , &
- 6123.98000000000 , &
- 6103.71000000000 , &
- 6083.53000000000 , &
- 6063.45000000000 , &
- 6043.44000000000 , &
- 6023.52000000000 , &
- 6003.73000000000 , &
- 5984.03000000000 , &
- 5964.38000000000 , &
- 5944.81000000000 /)
-
- Mref_V%vsv_ref( 601 : 630 ) = (/ &
- 5925.27000000000 , &
- 5550.32000000000 , &
- 5541.20000000000 , &
- 5532.08000000000 , &
- 5522.96000000000 , &
- 5513.83000000000 , &
- 5504.71000000000 , &
- 5495.59000000000 , &
- 5486.47000000000 , &
- 5477.35000000000 , &
- 5468.22000000000 , &
- 5459.10000000000 , &
- 5449.97000000000 , &
- 5440.84000000000 , &
- 5431.71000000000 , &
- 5422.57000000000 , &
- 5422.59000000000 , &
- 5406.39000000000 , &
- 5390.30000000000 , &
- 5374.34000000000 , &
- 5358.52000000000 , &
- 5342.83000000000 , &
- 5327.31000000000 , &
- 5311.92000000000 , &
- 5296.73000000000 , &
- 5281.71000000000 , &
- 5266.86000000000 , &
- 5252.21000000000 , &
- 5237.78000000000 , &
- 5223.55000000000 /)
-
- Mref_V%vsv_ref( 631 : 660 ) = (/ &
- 5209.54000000000 , &
- 5195.72000000000 , &
- 5182.10000000000 , &
- 5168.69000000000 , &
- 5155.42000000000 , &
- 5142.22000000000 , &
- 5129.05000000000 , &
- 5115.84000000000 , &
- 5102.55000000000 , &
- 5089.14000000000 , &
- 5075.50000000000 , &
- 5061.63000000000 , &
- 5047.46000000000 , &
- 5032.93000000000 , &
- 5018.03000000000 , &
- 5002.66000000000 , &
- 4986.77000000000 , &
- 4802.15000000000 , &
- 4798.23000000000 , &
- 4794.28000000000 , &
- 4790.38000000000 , &
- 4785.95000000000 , &
- 4780.83000000000 , &
- 4775.01000000000 , &
- 4768.45000000000 , &
- 4761.12000000000 , &
- 4752.97000000000 , &
- 4744.01000000000 , &
- 4734.25000000000 , &
- 4723.77000000000 /)
-
- Mref_V%vsv_ref( 661 : 690 ) = (/ &
- 4712.70000000000 , &
- 4701.12000000000 , &
- 4689.11000000000 , &
- 4676.77000000000 , &
- 4664.20000000000 , &
- 4651.49000000000 , &
- 4638.69000000000 , &
- 4625.88000000000 , &
- 4613.07000000000 , &
- 4600.31000000000 , &
- 4587.67000000000 , &
- 4575.18000000000 , &
- 4562.88000000000 , &
- 4550.85000000000 , &
- 4539.08000000000 , &
- 4527.67000000000 , &
- 4516.65000000000 , &
- 4506.09000000000 , &
- 4506.00000000000 , &
- 4496.29000000000 , &
- 4487.00000000000 , &
- 4478.17000000000 , &
- 4469.83000000000 , &
- 4462.00000000000 , &
- 4454.69000000000 , &
- 4447.94000000000 , &
- 4441.76000000000 , &
- 4436.18000000000 , &
- 4431.20000000000 , &
- 4426.83000000000 /)
-
- Mref_V%vsv_ref( 691 : 720 ) = (/ &
- 4423.12000000000 , &
- 4420.09000000000 , &
- 4417.81000000000 , &
- 4416.30000000000 , &
- 4415.67000000000 , &
- 4415.93000000000 , &
- 4417.15000000000 , &
- 4419.42000000000 , &
- 4422.78000000000 , &
- 4427.25000000000 , &
- 4432.88000000000 , &
- 4439.57000000000 , &
- 4439.74000000000 , &
- 4444.71000000000 , &
- 4450.28000000000 , &
- 4456.35000000000 , &
- 4462.89000000000 , &
- 4469.94000000000 , &
- 4477.40000000000 , &
- 4485.33000000000 , &
- 4493.69000000000 , &
- 4502.48000000000 , &
- 4511.66000000000 , &
- 4521.24000000000 , &
- 4531.23000000000 , &
- 4541.57000000000 , &
- 4552.08000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 /)
-
- Mref_V%vsv_ref( 721 : 750 ) = (/ &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 /)
-
- Mref_V%Qkappa_ref( 1 : 30 ) = (/ &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 /)
-
- Mref_V%Qkappa_ref( 31 : 60 ) = (/ &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 /)
-
- Mref_V%Qkappa_ref( 61 : 90 ) = (/ &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 /)
-
- Mref_V%Qkappa_ref( 91 : 120 ) = (/ &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 /)
-
- Mref_V%Qkappa_ref( 121 : 150 ) = (/ &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 /)
-
- Mref_V%Qkappa_ref( 151 : 180 ) = (/ &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 , &
- 1327.60000000000 /)
-
- Mref_V%Qkappa_ref( 181 : 210 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 211 : 240 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 241 : 270 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 271 : 300 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 301 : 330 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 331 : 360 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 361 : 390 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 391 : 420 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 421 : 450 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 451 : 480 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 481 : 510 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 511 : 540 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 541 : 570 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 571 : 600 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 601 : 630 ) = (/ &
- 57822.5000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 /)
-
- Mref_V%Qkappa_ref( 631 : 660 ) = (/ &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 /)
-
- Mref_V%Qkappa_ref( 661 : 690 ) = (/ &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 /)
-
- Mref_V%Qkappa_ref( 691 : 720 ) = (/ &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 943.000000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qkappa_ref( 721 : 750 ) = (/ &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 , &
- 57822.5000000000 /)
-
- Mref_V%Qmu_ref( 1 : 30 ) = (/ &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 /)
-
- Mref_V%Qmu_ref( 31 : 60 ) = (/ &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 /)
-
- Mref_V%Qmu_ref( 61 : 90 ) = (/ &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 /)
-
- Mref_V%Qmu_ref( 91 : 120 ) = (/ &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 /)
-
- Mref_V%Qmu_ref( 121 : 150 ) = (/ &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 /)
-
- Mref_V%Qmu_ref( 151 : 180 ) = (/ &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 , &
- 104.000000000000 /)
-
- Mref_V%Qmu_ref( 181 : 210 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%Qmu_ref( 211 : 240 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%Qmu_ref( 241 : 270 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%Qmu_ref( 271 : 300 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%Qmu_ref( 301 : 330 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%Qmu_ref( 331 : 360 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 355.000000000000 , &
- 355.000000000000 /)
-
- Mref_V%Qmu_ref( 361 : 390 ) = (/ &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 /)
-
- Mref_V%Qmu_ref( 391 : 420 ) = (/ &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 /)
-
- Mref_V%Qmu_ref( 421 : 450 ) = (/ &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 /)
-
- Mref_V%Qmu_ref( 451 : 480 ) = (/ &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 /)
-
- Mref_V%Qmu_ref( 481 : 510 ) = (/ &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 /)
-
- Mref_V%Qmu_ref( 511 : 540 ) = (/ &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 /)
-
- Mref_V%Qmu_ref( 541 : 570 ) = (/ &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 /)
-
- Mref_V%Qmu_ref( 571 : 600 ) = (/ &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 , &
- 355.000000000000 /)
-
- Mref_V%Qmu_ref( 601 : 630 ) = (/ &
- 355.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 /)
-
- Mref_V%Qmu_ref( 631 : 660 ) = (/ &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 /)
-
- Mref_V%Qmu_ref( 661 : 690 ) = (/ &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 165.000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 /)
-
- Mref_V%Qmu_ref( 691 : 720 ) = (/ &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 70.0000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 191.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 /)
-
- Mref_V%Qmu_ref( 721 : 750 ) = (/ &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 , &
- 300.000000000000 /)
-
- Mref_V%vph_ref( 1 : 30 ) = (/ &
- 11262.2000000000 , &
- 11262.2000000000 , &
- 11262.1800000000 , &
- 11262.1400000000 , &
- 11262.0900000000 , &
- 11262.0200000000 , &
- 11261.9400000000 , &
- 11261.8500000000 , &
- 11261.7400000000 , &
- 11261.6100000000 , &
- 11261.4700000000 , &
- 11261.3200000000 , &
- 11261.1500000000 , &
- 11260.9700000000 , &
- 11260.7700000000 , &
- 11260.5600000000 , &
- 11260.3400000000 , &
- 11260.0900000000 , &
- 11259.8400000000 , &
- 11259.5700000000 , &
- 11259.2800000000 , &
- 11258.9900000000 , &
- 11258.6700000000 , &
- 11258.3400000000 , &
- 11258.0000000000 , &
- 11257.6400000000 , &
- 11257.2700000000 , &
- 11256.8800000000 , &
- 11256.4800000000 , &
- 11256.0600000000 /)
-
- Mref_V%vph_ref( 31 : 60 ) = (/ &
- 11255.6300000000 , &
- 11255.1900000000 , &
- 11254.7300000000 , &
- 11254.2500000000 , &
- 11253.7600000000 , &
- 11253.2600000000 , &
- 11252.7400000000 , &
- 11252.2100000000 , &
- 11251.6600000000 , &
- 11251.1000000000 , &
- 11250.5200000000 , &
- 11249.9300000000 , &
- 11249.3300000000 , &
- 11248.7100000000 , &
- 11248.0700000000 , &
- 11247.4200000000 , &
- 11246.7600000000 , &
- 11246.0800000000 , &
- 11245.3800000000 , &
- 11244.6700000000 , &
- 11243.9500000000 , &
- 11243.2100000000 , &
- 11242.4600000000 , &
- 11241.7000000000 , &
- 11240.9100000000 , &
- 11240.1200000000 , &
- 11239.3100000000 , &
- 11238.4800000000 , &
- 11237.6400000000 , &
- 11236.7900000000 /)
-
- Mref_V%vph_ref( 61 : 90 ) = (/ &
- 11235.9200000000 , &
- 11235.0400000000 , &
- 11234.1400000000 , &
- 11233.2300000000 , &
- 11232.3000000000 , &
- 11231.3600000000 , &
- 11230.4000000000 , &
- 11229.4300000000 , &
- 11228.4400000000 , &
- 11227.4400000000 , &
- 11226.4300000000 , &
- 11225.4000000000 , &
- 11224.3600000000 , &
- 11223.3000000000 , &
- 11222.2200000000 , &
- 11221.1400000000 , &
- 11220.0300000000 , &
- 11218.9200000000 , &
- 11217.7800000000 , &
- 11216.6400000000 , &
- 11215.4800000000 , &
- 11214.3000000000 , &
- 11213.1100000000 , &
- 11211.9100000000 , &
- 11210.6900000000 , &
- 11209.4500000000 , &
- 11208.2100000000 , &
- 11206.9400000000 , &
- 11205.6700000000 , &
- 11204.3700000000 /)
-
- Mref_V%vph_ref( 91 : 120 ) = (/ &
- 11203.0700000000 , &
- 11201.7400000000 , &
- 11200.4100000000 , &
- 11199.0600000000 , &
- 11197.6900000000 , &
- 11196.3100000000 , &
- 11194.9200000000 , &
- 11193.5100000000 , &
- 11192.0900000000 , &
- 11190.6500000000 , &
- 11189.1900000000 , &
- 11187.7300000000 , &
- 11186.2400000000 , &
- 11184.7500000000 , &
- 11183.2400000000 , &
- 11181.7100000000 , &
- 11180.1700000000 , &
- 11178.6100000000 , &
- 11177.0400000000 , &
- 11175.4600000000 , &
- 11173.8600000000 , &
- 11172.2500000000 , &
- 11170.6200000000 , &
- 11168.9800000000 , &
- 11167.3200000000 , &
- 11165.6500000000 , &
- 11163.9600000000 , &
- 11162.2600000000 , &
- 11160.5400000000 , &
- 11158.8100000000 /)
-
- Mref_V%vph_ref( 121 : 150 ) = (/ &
- 11157.0700000000 , &
- 11155.3100000000 , &
- 11153.5400000000 , &
- 11151.7500000000 , &
- 11149.9400000000 , &
- 11148.1300000000 , &
- 11146.2900000000 , &
- 11144.4500000000 , &
- 11142.5800000000 , &
- 11140.7100000000 , &
- 11138.8200000000 , &
- 11136.9100000000 , &
- 11134.9900000000 , &
- 11133.0600000000 , &
- 11131.1100000000 , &
- 11129.1400000000 , &
- 11127.1600000000 , &
- 11125.1700000000 , &
- 11123.1600000000 , &
- 11121.1400000000 , &
- 11119.1000000000 , &
- 11117.0500000000 , &
- 11114.9900000000 , &
- 11112.9000000000 , &
- 11110.8100000000 , &
- 11108.7000000000 , &
- 11106.5700000000 , &
- 11104.4400000000 , &
- 11102.2800000000 , &
- 11100.1100000000 /)
-
- Mref_V%vph_ref( 151 : 180 ) = (/ &
- 11097.9300000000 , &
- 11095.7300000000 , &
- 11093.5200000000 , &
- 11091.2900000000 , &
- 11089.0500000000 , &
- 11086.8000000000 , &
- 11084.5300000000 , &
- 11082.2400000000 , &
- 11079.9400000000 , &
- 11077.6300000000 , &
- 11075.3000000000 , &
- 11072.9500000000 , &
- 11070.5900000000 , &
- 11068.2200000000 , &
- 11065.8300000000 , &
- 11063.4300000000 , &
- 11061.0200000000 , &
- 11058.5800000000 , &
- 11056.1400000000 , &
- 11053.6800000000 , &
- 11051.2000000000 , &
- 11048.7100000000 , &
- 11046.2100000000 , &
- 11043.6900000000 , &
- 11041.1600000000 , &
- 11038.6100000000 , &
- 11036.0500000000 , &
- 11033.4700000000 , &
- 11030.8800000000 , &
- 11028.2700000000 /)
-
- Mref_V%vph_ref( 181 : 210 ) = (/ &
- 10355.6900000000 , &
- 10348.2800000000 , &
- 10340.8500000000 , &
- 10333.3900000000 , &
- 10325.9100000000 , &
- 10318.4000000000 , &
- 10310.8700000000 , &
- 10303.3000000000 , &
- 10295.7100000000 , &
- 10288.0900000000 , &
- 10280.4400000000 , &
- 10272.7600000000 , &
- 10265.0400000000 , &
- 10257.3000000000 , &
- 10249.5200000000 , &
- 10241.7100000000 , &
- 10233.8600000000 , &
- 10225.9800000000 , &
- 10218.0600000000 , &
- 10210.1100000000 , &
- 10202.1200000000 , &
- 10194.1000000000 , &
- 10186.0400000000 , &
- 10177.9400000000 , &
- 10169.7900000000 , &
- 10161.6100000000 , &
- 10153.3900000000 , &
- 10145.1300000000 , &
- 10136.8300000000 , &
- 10128.4800000000 /)
-
- Mref_V%vph_ref( 211 : 240 ) = (/ &
- 10120.0900000000 , &
- 10111.6600000000 , &
- 10103.1800000000 , &
- 10094.6600000000 , &
- 10086.0900000000 , &
- 10077.4800000000 , &
- 10068.8200000000 , &
- 10060.1100000000 , &
- 10051.3500000000 , &
- 10042.5400000000 , &
- 10033.6900000000 , &
- 10024.7800000000 , &
- 10015.8200000000 , &
- 10006.8200000000 , &
- 9997.75000000000 , &
- 9988.64000000000 , &
- 9979.47000000000 , &
- 9970.25000000000 , &
- 9960.97000000000 , &
- 9951.64000000000 , &
- 9942.25000000000 , &
- 9932.81000000000 , &
- 9923.31000000000 , &
- 9913.75000000000 , &
- 9904.13000000000 , &
- 9894.45000000000 , &
- 9884.71000000000 , &
- 9874.91000000000 , &
- 9865.05000000000 , &
- 9855.13000000000 /)
-
- Mref_V%vph_ref( 241 : 270 ) = (/ &
- 9845.14000000000 , &
- 9835.09000000000 , &
- 9824.98000000000 , &
- 9814.80000000000 , &
- 9804.56000000000 , &
- 9794.25000000000 , &
- 9783.87000000000 , &
- 9773.43000000000 , &
- 9762.92000000000 , &
- 9752.34000000000 , &
- 9741.69000000000 , &
- 9730.97000000000 , &
- 9720.18000000000 , &
- 9709.32000000000 , &
- 9698.39000000000 , &
- 9687.38000000000 , &
- 9676.31000000000 , &
- 9665.15000000000 , &
- 9653.93000000000 , &
- 9642.63000000000 , &
- 9631.25000000000 , &
- 9619.80000000000 , &
- 9608.27000000000 , &
- 9596.66000000000 , &
- 9584.97000000000 , &
- 9573.20000000000 , &
- 9561.36000000000 , &
- 9549.43000000000 , &
- 9537.43000000000 , &
- 9525.34000000000 /)
-
- Mref_V%vph_ref( 271 : 300 ) = (/ &
- 9513.17000000000 , &
- 9500.91000000000 , &
- 9488.57000000000 , &
- 9476.15000000000 , &
- 9463.64000000000 , &
- 9451.05000000000 , &
- 9438.37000000000 , &
- 9425.61000000000 , &
- 9412.75000000000 , &
- 9399.81000000000 , &
- 9386.78000000000 , &
- 9373.66000000000 , &
- 9360.45000000000 , &
- 9347.15000000000 , &
- 9333.76000000000 , &
- 9320.27000000000 , &
- 9306.70000000000 , &
- 9293.03000000000 , &
- 9279.26000000000 , &
- 9265.40000000000 , &
- 9251.45000000000 , &
- 9237.40000000000 , &
- 9223.25000000000 , &
- 9209.00000000000 , &
- 9194.66000000000 , &
- 9180.22000000000 , &
- 9165.68000000000 , &
- 9151.03000000000 , &
- 9136.29000000000 , &
- 9121.45000000000 /)
-
- Mref_V%vph_ref( 301 : 330 ) = (/ &
- 9106.50000000000 , &
- 9091.46000000000 , &
- 9076.30000000000 , &
- 9061.05000000000 , &
- 9045.69000000000 , &
- 9030.23000000000 , &
- 9014.65000000000 , &
- 8998.98000000000 , &
- 8983.19000000000 , &
- 8967.30000000000 , &
- 8951.30000000000 , &
- 8935.19000000000 , &
- 8918.97000000000 , &
- 8902.64000000000 , &
- 8886.20000000000 , &
- 8869.64000000000 , &
- 8852.98000000000 , &
- 8836.20000000000 , &
- 8819.31000000000 , &
- 8802.30000000000 , &
- 8785.18000000000 , &
- 8767.94000000000 , &
- 8750.59000000000 , &
- 8733.12000000000 , &
- 8715.53000000000 , &
- 8697.82000000000 , &
- 8680.00000000000 , &
- 8662.05000000000 , &
- 8643.99000000000 , &
- 8625.80000000000 /)
-
- Mref_V%vph_ref( 331 : 360 ) = (/ &
- 8607.49000000000 , &
- 8589.06000000000 , &
- 8570.51000000000 , &
- 8551.83000000000 , &
- 8533.03000000000 , &
- 8514.10000000000 , &
- 8495.05000000000 , &
- 8475.87000000000 , &
- 8456.57000000000 , &
- 8437.14000000000 , &
- 8417.58000000000 , &
- 8397.89000000000 , &
- 8378.07000000000 , &
- 8358.12000000000 , &
- 8338.04000000000 , &
- 8317.83000000000 , &
- 8297.49000000000 , &
- 8277.01000000000 , &
- 8256.41000000000 , &
- 8235.66000000000 , &
- 8214.79000000000 , &
- 8193.77000000000 , &
- 8172.62000000000 , &
- 8151.34000000000 , &
- 8129.92000000000 , &
- 8108.36000000000 , &
- 8086.66000000000 , &
- 8064.82000000000 , &
- 13716.6000000000 , &
- 13714.2900000000 /)
-
- Mref_V%vph_ref( 361 : 390 ) = (/ &
- 13712.0000000000 , &
- 13709.7000000000 , &
- 13707.4200000000 , &
- 13705.1400000000 , &
- 13702.8600000000 , &
- 13700.5900000000 , &
- 13698.3300000000 , &
- 13696.0700000000 , &
- 13693.8200000000 , &
- 13691.5700000000 , &
- 13689.3300000000 , &
- 13687.0900000000 , &
- 13684.8600000000 , &
- 13682.6300000000 , &
- 13680.4100000000 , &
- 13680.4100000000 , &
- 13668.9000000000 , &
- 13657.4300000000 , &
- 13645.9700000000 , &
- 13634.5400000000 , &
- 13623.1400000000 , &
- 13611.7600000000 , &
- 13600.4000000000 , &
- 13589.0700000000 , &
- 13577.7600000000 , &
- 13566.4700000000 , &
- 13555.2000000000 , &
- 13543.9500000000 , &
- 13532.7200000000 , &
- 13521.5100000000 /)
-
- Mref_V%vph_ref( 391 : 420 ) = (/ &
- 13510.3200000000 , &
- 13499.1400000000 , &
- 13487.9900000000 , &
- 13476.8500000000 , &
- 13465.7300000000 , &
- 13454.6300000000 , &
- 13443.5400000000 , &
- 13432.4600000000 , &
- 13421.4100000000 , &
- 13410.3600000000 , &
- 13399.3300000000 , &
- 13388.3100000000 , &
- 13377.3100000000 , &
- 13366.3100000000 , &
- 13355.3300000000 , &
- 13344.3600000000 , &
- 13333.4000000000 , &
- 13322.4500000000 , &
- 13311.5100000000 , &
- 13300.5800000000 , &
- 13289.6600000000 , &
- 13278.7400000000 , &
- 13267.8400000000 , &
- 13256.9300000000 , &
- 13246.0400000000 , &
- 13235.1500000000 , &
- 13224.2700000000 , &
- 13213.3900000000 , &
- 13202.5100000000 , &
- 13191.6400000000 /)
-
- Mref_V%vph_ref( 421 : 450 ) = (/ &
- 13180.7800000000 , &
- 13169.9100000000 , &
- 13159.0500000000 , &
- 13148.1900000000 , &
- 13137.3300000000 , &
- 13126.4700000000 , &
- 13115.6100000000 , &
- 13104.7500000000 , &
- 13093.8900000000 , &
- 13083.0200000000 , &
- 13072.1600000000 , &
- 13061.2900000000 , &
- 13050.4200000000 , &
- 13039.5500000000 , &
- 13028.6700000000 , &
- 13017.7800000000 , &
- 13006.9000000000 , &
- 12996.0000000000 , &
- 12985.1000000000 , &
- 12974.1900000000 , &
- 12963.2800000000 , &
- 12952.3600000000 , &
- 12941.4200000000 , &
- 12930.4800000000 , &
- 12919.5400000000 , &
- 12908.5800000000 , &
- 12897.6100000000 , &
- 12886.6300000000 , &
- 12875.6300000000 , &
- 12864.6300000000 /)
-
- Mref_V%vph_ref( 451 : 480 ) = (/ &
- 12853.6100000000 , &
- 12842.5800000000 , &
- 12831.5400000000 , &
- 12820.4800000000 , &
- 12809.4100000000 , &
- 12798.3200000000 , &
- 12787.2200000000 , &
- 12776.1000000000 , &
- 12764.9600000000 , &
- 12753.8100000000 , &
- 12742.6300000000 , &
- 12731.4400000000 , &
- 12720.2400000000 , &
- 12709.0100000000 , &
- 12697.7600000000 , &
- 12686.4900000000 , &
- 12675.2000000000 , &
- 12663.8900000000 , &
- 12652.5600000000 , &
- 12641.2000000000 , &
- 12629.8200000000 , &
- 12618.4200000000 , &
- 12606.9900000000 , &
- 12595.5400000000 , &
- 12584.0600000000 , &
- 12572.5600000000 , &
- 12561.0300000000 , &
- 12549.4800000000 , &
- 12537.8900000000 , &
- 12526.2800000000 /)
-
- Mref_V%vph_ref( 481 : 510 ) = (/ &
- 12514.6400000000 , &
- 12502.9800000000 , &
- 12491.2800000000 , &
- 12479.5500000000 , &
- 12467.7900000000 , &
- 12456.0100000000 , &
- 12444.1900000000 , &
- 12432.3300000000 , &
- 12420.4500000000 , &
- 12408.5300000000 , &
- 12396.5800000000 , &
- 12384.6000000000 , &
- 12372.5800000000 , &
- 12360.5200000000 , &
- 12348.4300000000 , &
- 12336.3000000000 , &
- 12324.1400000000 , &
- 12311.9400000000 , &
- 12299.7000000000 , &
- 12287.4200000000 , &
- 12275.1100000000 , &
- 12262.7500000000 , &
- 12250.3500000000 , &
- 12237.9200000000 , &
- 12225.4400000000 , &
- 12212.9200000000 , &
- 12200.3600000000 , &
- 12187.7600000000 , &
- 12175.1100000000 , &
- 12162.4300000000 /)
-
- Mref_V%vph_ref( 511 : 540 ) = (/ &
- 12149.6900000000 , &
- 12136.9100000000 , &
- 12124.0900000000 , &
- 12111.2200000000 , &
- 12098.3100000000 , &
- 12085.3400000000 , &
- 12072.3400000000 , &
- 12059.2800000000 , &
- 12046.1700000000 , &
- 12033.0200000000 , &
- 12019.8200000000 , &
- 12006.5600000000 , &
- 11993.2600000000 , &
- 11979.9000000000 , &
- 11966.5000000000 , &
- 11953.0400000000 , &
- 11939.5300000000 , &
- 11925.9700000000 , &
- 11912.3500000000 , &
- 11898.6900000000 , &
- 11884.9600000000 , &
- 11871.1900000000 , &
- 11857.3700000000 , &
- 11843.4800000000 , &
- 11829.5500000000 , &
- 11815.5700000000 , &
- 11801.5300000000 , &
- 11787.4400000000 , &
- 11773.3000000000 , &
- 11759.1000000000 /)
-
- Mref_V%vph_ref( 541 : 570 ) = (/ &
- 11744.8500000000 , &
- 11730.5500000000 , &
- 11716.1800000000 , &
- 11701.7800000000 , &
- 11687.3100000000 , &
- 11672.8000000000 , &
- 11658.2300000000 , &
- 11643.6000000000 , &
- 11628.9200000000 , &
- 11614.1900000000 , &
- 11599.4000000000 , &
- 11584.5700000000 , &
- 11569.6800000000 , &
- 11554.7200000000 , &
- 11539.7200000000 , &
- 11524.6700000000 , &
- 11509.5600000000 , &
- 11494.3900000000 , &
- 11479.1700000000 , &
- 11463.8900000000 , &
- 11448.5500000000 , &
- 11433.1700000000 , &
- 11417.7300000000 , &
- 11402.2300000000 , &
- 11386.6800000000 , &
- 11371.0700000000 , &
- 11355.4100000000 , &
- 11339.6900000000 , &
- 11323.9100000000 , &
- 11308.0900000000 /)
-
- Mref_V%vph_ref( 571 : 600 ) = (/ &
- 11292.2000000000 , &
- 11276.2500000000 , &
- 11260.2500000000 , &
- 11244.1900000000 , &
- 11228.0800000000 , &
- 11211.9000000000 , &
- 11195.6700000000 , &
- 11179.3800000000 , &
- 11163.0400000000 , &
- 11146.6300000000 , &
- 11130.1800000000 , &
- 11113.6700000000 , &
- 11097.1100000000 , &
- 11080.5100000000 , &
- 11080.5100000000 , &
- 11063.0100000000 , &
- 11045.2200000000 , &
- 11026.8200000000 , &
- 11008.4700000000 , &
- 10989.0400000000 , &
- 10969.6300000000 , &
- 10948.7600000000 , &
- 10928.0200000000 , &
- 10907.4200000000 , &
- 10886.9400000000 , &
- 10866.6000000000 , &
- 10846.4100000000 , &
- 10826.3500000000 , &
- 10806.4200000000 , &
- 10786.6100000000 /)
-
- Mref_V%vph_ref( 601 : 630 ) = (/ &
- 10766.9000000000 , &
- 10278.8800000000 , &
- 10261.8700000000 , &
- 10244.8400000000 , &
- 10227.8200000000 , &
- 10210.8000000000 , &
- 10193.7800000000 , &
- 10176.7700000000 , &
- 10159.7400000000 , &
- 10142.7200000000 , &
- 10125.7100000000 , &
- 10108.7000000000 , &
- 10091.6800000000 , &
- 10074.6800000000 , &
- 10057.6800000000 , &
- 10040.6400000000 , &
- 10040.6700000000 , &
- 10010.5200000000 , &
- 9980.51000000000 , &
- 9950.64000000000 , &
- 9920.91000000000 , &
- 9891.35000000000 , &
- 9861.96000000000 , &
- 9832.79000000000 , &
- 9803.79000000000 , &
- 9774.98000000000 , &
- 9746.41000000000 , &
- 9718.08000000000 , &
- 9689.96000000000 , &
- 9662.10000000000 /)
-
- Mref_V%vph_ref( 631 : 660 ) = (/ &
- 9634.47000000000 , &
- 9607.11000000000 , &
- 9579.97000000000 , &
- 9553.08000000000 , &
- 9526.38000000000 , &
- 9499.78000000000 , &
- 9473.25000000000 , &
- 9446.74000000000 , &
- 9420.19000000000 , &
- 9393.55000000000 , &
- 9366.75000000000 , &
- 9339.76000000000 , &
- 9312.50000000000 , &
- 9284.96000000000 , &
- 9257.04000000000 , &
- 9228.73000000000 , &
- 9199.94000000000 , &
- 8940.94000000000 , &
- 8930.61000000000 , &
- 8920.22000000000 , &
- 8909.68000000000 , &
- 8898.47000000000 , &
- 8886.28000000000 , &
- 8873.03000000000 , &
- 8858.58000000000 , &
- 8842.82000000000 , &
- 8825.64000000000 , &
- 8806.94000000000 , &
- 8786.67000000000 , &
- 8764.85000000000 /)
-
- Mref_V%vph_ref( 661 : 690 ) = (/ &
- 8741.49000000000 , &
- 8716.63000000000 , &
- 8690.30000000000 , &
- 8662.50000000000 , &
- 8633.28000000000 , &
- 8602.66000000000 , &
- 8570.81000000000 , &
- 8538.06000000000 , &
- 8504.66000000000 , &
- 8470.92000000000 , &
- 8437.13000000000 , &
- 8403.52000000000 , &
- 8370.42000000000 , &
- 8338.11000000000 , &
- 8307.42000000000 , &
- 8278.36000000000 , &
- 8255.33000000000 , &
- 8236.90000000000 , &
- 8236.81000000000 , &
- 8222.27000000000 , &
- 8210.47000000000 , &
- 8201.14000000000 , &
- 8193.99000000000 , &
- 8188.67000000000 , &
- 8184.92000000000 , &
- 8182.39000000000 , &
- 8180.79000000000 , &
- 8179.83000000000 , &
- 8179.17000000000 , &
- 8178.54000000000 /)
-
- Mref_V%vph_ref( 691 : 720 ) = (/ &
- 8177.64000000000 , &
- 8176.30000000000 , &
- 8174.55000000000 , &
- 8172.42000000000 , &
- 8169.91000000000 , &
- 8167.05000000000 , &
- 8163.88000000000 , &
- 8160.37000000000 , &
- 8156.58000000000 , &
- 8152.57000000000 , &
- 8148.41000000000 , &
- 8144.20000000000 , &
- 8144.32000000000 , &
- 8141.60000000000 , &
- 8139.01000000000 , &
- 8136.50000000000 , &
- 8134.11000000000 , &
- 8131.82000000000 , &
- 8129.66000000000 , &
- 8127.60000000000 , &
- 8125.65000000000 , &
- 8123.87000000000 , &
- 8122.23000000000 , &
- 8120.74000000000 , &
- 8119.38000000000 , &
- 8118.22000000000 , &
- 8117.13000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 /)
-
- Mref_V%vph_ref( 721 : 750 ) = (/ &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 6800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 , &
- 5800.00000000000 /)
-
- Mref_V%vsh_ref( 1 : 30 ) = (/ &
- 3667.80000000000 , &
- 3667.79000000000 , &
- 3667.78000000000 , &
- 3667.75000000000 , &
- 3667.72000000000 , &
- 3667.67000000000 , &
- 3667.62000000000 , &
- 3667.55000000000 , &
- 3667.47000000000 , &
- 3667.39000000000 , &
- 3667.29000000000 , &
- 3667.18000000000 , &
- 3667.06000000000 , &
- 3666.94000000000 , &
- 3666.80000000000 , &
- 3666.65000000000 , &
- 3666.49000000000 , &
- 3666.32000000000 , &
- 3666.15000000000 , &
- 3665.96000000000 , &
- 3665.76000000000 , &
- 3665.55000000000 , &
- 3665.33000000000 , &
- 3665.10000000000 , &
- 3664.86000000000 , &
- 3664.61000000000 , &
- 3664.35000000000 , &
- 3664.08000000000 , &
- 3663.80000000000 , &
- 3663.51000000000 /)
-
- Mref_V%vsh_ref( 31 : 60 ) = (/ &
- 3663.21000000000 , &
- 3662.90000000000 , &
- 3662.57000000000 , &
- 3662.24000000000 , &
- 3661.90000000000 , &
- 3661.55000000000 , &
- 3661.19000000000 , &
- 3660.81000000000 , &
- 3660.43000000000 , &
- 3660.04000000000 , &
- 3659.64000000000 , &
- 3659.22000000000 , &
- 3658.80000000000 , &
- 3658.36000000000 , &
- 3657.92000000000 , &
- 3657.47000000000 , &
- 3657.00000000000 , &
- 3656.53000000000 , &
- 3656.04000000000 , &
- 3655.55000000000 , &
- 3655.04000000000 , &
- 3654.53000000000 , &
- 3654.00000000000 , &
- 3653.47000000000 , &
- 3652.92000000000 , &
- 3652.36000000000 , &
- 3651.80000000000 , &
- 3651.22000000000 , &
- 3650.63000000000 , &
- 3650.04000000000 /)
-
- Mref_V%vsh_ref( 61 : 90 ) = (/ &
- 3649.43000000000 , &
- 3648.81000000000 , &
- 3648.19000000000 , &
- 3647.55000000000 , &
- 3646.90000000000 , &
- 3646.24000000000 , &
- 3645.57000000000 , &
- 3644.89000000000 , &
- 3644.21000000000 , &
- 3643.51000000000 , &
- 3642.80000000000 , &
- 3642.08000000000 , &
- 3641.35000000000 , &
- 3640.61000000000 , &
- 3639.86000000000 , &
- 3639.10000000000 , &
- 3638.33000000000 , &
- 3637.55000000000 , &
- 3636.76000000000 , &
- 3635.96000000000 , &
- 3635.14000000000 , &
- 3634.32000000000 , &
- 3633.49000000000 , &
- 3632.65000000000 , &
- 3631.80000000000 , &
- 3630.93000000000 , &
- 3630.06000000000 , &
- 3629.18000000000 , &
- 3628.29000000000 , &
- 3627.38000000000 /)
-
- Mref_V%vsh_ref( 91 : 120 ) = (/ &
- 3626.47000000000 , &
- 3625.55000000000 , &
- 3624.61000000000 , &
- 3623.67000000000 , &
- 3622.71000000000 , &
- 3621.75000000000 , &
- 3620.78000000000 , &
- 3619.79000000000 , &
- 3618.80000000000 , &
- 3617.79000000000 , &
- 3616.78000000000 , &
- 3615.75000000000 , &
- 3614.71000000000 , &
- 3613.67000000000 , &
- 3612.61000000000 , &
- 3611.55000000000 , &
- 3610.47000000000 , &
- 3609.38000000000 , &
- 3608.28000000000 , &
- 3607.18000000000 , &
- 3606.06000000000 , &
- 3604.93000000000 , &
- 3603.79000000000 , &
- 3602.65000000000 , &
- 3601.49000000000 , &
- 3600.32000000000 , &
- 3599.14000000000 , &
- 3597.95000000000 , &
- 3596.75000000000 , &
- 3595.54000000000 /)
-
- Mref_V%vsh_ref( 121 : 150 ) = (/ &
- 3594.32000000000 , &
- 3593.10000000000 , &
- 3591.86000000000 , &
- 3590.61000000000 , &
- 3589.34000000000 , &
- 3588.07000000000 , &
- 3586.79000000000 , &
- 3585.50000000000 , &
- 3584.20000000000 , &
- 3582.89000000000 , &
- 3581.57000000000 , &
- 3580.24000000000 , &
- 3578.90000000000 , &
- 3577.54000000000 , &
- 3576.18000000000 , &
- 3574.81000000000 , &
- 3573.43000000000 , &
- 3572.03000000000 , &
- 3570.63000000000 , &
- 3569.22000000000 , &
- 3567.79000000000 , &
- 3566.36000000000 , &
- 3564.91000000000 , &
- 3563.46000000000 , &
- 3562.00000000000 , &
- 3560.52000000000 , &
- 3559.04000000000 , &
- 3557.54000000000 , &
- 3556.04000000000 , &
- 3554.52000000000 /)
-
- Mref_V%vsh_ref( 151 : 180 ) = (/ &
- 3553.00000000000 , &
- 3551.46000000000 , &
- 3549.91000000000 , &
- 3548.36000000000 , &
- 3546.79000000000 , &
- 3545.21000000000 , &
- 3543.63000000000 , &
- 3542.03000000000 , &
- 3540.42000000000 , &
- 3538.81000000000 , &
- 3537.18000000000 , &
- 3535.54000000000 , &
- 3533.89000000000 , &
- 3532.23000000000 , &
- 3530.57000000000 , &
- 3528.89000000000 , &
- 3527.20000000000 , &
- 3525.50000000000 , &
- 3523.79000000000 , &
- 3522.07000000000 , &
- 3520.34000000000 , &
- 3518.60000000000 , &
- 3516.85000000000 , &
- 3515.09000000000 , &
- 3513.32000000000 , &
- 3511.54000000000 , &
- 3509.75000000000 , &
- 3507.95000000000 , &
- 3506.13000000000 , &
- 3504.31000000000 /)
-
- Mref_V%vsh_ref( 181 : 210 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%vsh_ref( 211 : 240 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%vsh_ref( 241 : 270 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%vsh_ref( 271 : 300 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%vsh_ref( 301 : 330 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 /)
-
- Mref_V%vsh_ref( 331 : 360 ) = (/ &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 0.000000000000000E+000 , &
- 7264.66000000000 , &
- 7264.75000000000 /)
-
- Mref_V%vsh_ref( 361 : 390 ) = (/ &
- 7264.85000000000 , &
- 7264.94000000000 , &
- 7265.03000000000 , &
- 7265.12000000000 , &
- 7265.21000000000 , &
- 7265.29000000000 , &
- 7265.38000000000 , &
- 7265.46000000000 , &
- 7265.54000000000 , &
- 7265.62000000000 , &
- 7265.69000000000 , &
- 7265.76000000000 , &
- 7265.84000000000 , &
- 7265.91000000000 , &
- 7265.97000000000 , &
- 7265.97000000000 , &
- 7261.63000000000 , &
- 7257.29000000000 , &
- 7252.97000000000 , &
- 7248.64000000000 , &
- 7244.33000000000 , &
- 7240.01000000000 , &
- 7235.71000000000 , &
- 7231.41000000000 , &
- 7227.12000000000 , &
- 7222.83000000000 , &
- 7218.55000000000 , &
- 7214.27000000000 , &
- 7210.00000000000 , &
- 7205.73000000000 /)
-
- Mref_V%vsh_ref( 391 : 420 ) = (/ &
- 7201.47000000000 , &
- 7197.21000000000 , &
- 7192.95000000000 , &
- 7188.70000000000 , &
- 7184.45000000000 , &
- 7180.21000000000 , &
- 7175.97000000000 , &
- 7171.73000000000 , &
- 7167.50000000000 , &
- 7163.27000000000 , &
- 7159.04000000000 , &
- 7154.81000000000 , &
- 7150.59000000000 , &
- 7146.37000000000 , &
- 7142.15000000000 , &
- 7137.93000000000 , &
- 7133.71000000000 , &
- 7129.50000000000 , &
- 7125.29000000000 , &
- 7121.07000000000 , &
- 7116.86000000000 , &
- 7112.65000000000 , &
- 7108.44000000000 , &
- 7104.23000000000 , &
- 7100.02000000000 , &
- 7095.81000000000 , &
- 7091.60000000000 , &
- 7087.39000000000 , &
- 7083.18000000000 , &
- 7078.96000000000 /)
-
- Mref_V%vsh_ref( 421 : 450 ) = (/ &
- 7074.75000000000 , &
- 7070.54000000000 , &
- 7066.32000000000 , &
- 7062.10000000000 , &
- 7057.88000000000 , &
- 7053.66000000000 , &
- 7049.44000000000 , &
- 7045.22000000000 , &
- 7040.99000000000 , &
- 7036.76000000000 , &
- 7032.52000000000 , &
- 7028.29000000000 , &
- 7024.05000000000 , &
- 7019.81000000000 , &
- 7015.56000000000 , &
- 7011.31000000000 , &
- 7007.06000000000 , &
- 7002.80000000000 , &
- 6998.54000000000 , &
- 6994.27000000000 , &
- 6990.00000000000 , &
- 6985.72000000000 , &
- 6981.44000000000 , &
- 6977.15000000000 , &
- 6972.86000000000 , &
- 6968.57000000000 , &
- 6964.26000000000 , &
- 6959.95000000000 , &
- 6955.64000000000 , &
- 6951.32000000000 /)
-
- Mref_V%vsh_ref( 451 : 480 ) = (/ &
- 6946.99000000000 , &
- 6942.66000000000 , &
- 6938.31000000000 , &
- 6933.97000000000 , &
- 6929.61000000000 , &
- 6925.25000000000 , &
- 6920.88000000000 , &
- 6916.50000000000 , &
- 6912.11000000000 , &
- 6907.72000000000 , &
- 6903.32000000000 , &
- 6898.91000000000 , &
- 6894.49000000000 , &
- 6890.06000000000 , &
- 6885.62000000000 , &
- 6881.17000000000 , &
- 6876.72000000000 , &
- 6872.25000000000 , &
- 6867.78000000000 , &
- 6863.29000000000 , &
- 6858.80000000000 , &
- 6854.29000000000 , &
- 6849.78000000000 , &
- 6845.25000000000 , &
- 6840.71000000000 , &
- 6836.16000000000 , &
- 6831.60000000000 , &
- 6827.03000000000 , &
- 6822.45000000000 , &
- 6817.85000000000 /)
-
- Mref_V%vsh_ref( 481 : 510 ) = (/ &
- 6813.25000000000 , &
- 6808.63000000000 , &
- 6804.00000000000 , &
- 6799.35000000000 , &
- 6794.70000000000 , &
- 6790.03000000000 , &
- 6785.34000000000 , &
- 6780.65000000000 , &
- 6775.94000000000 , &
- 6771.22000000000 , &
- 6766.48000000000 , &
- 6761.73000000000 , &
- 6756.97000000000 , &
- 6752.19000000000 , &
- 6747.40000000000 , &
- 6742.59000000000 , &
- 6737.76000000000 , &
- 6732.93000000000 , &
- 6728.07000000000 , &
- 6723.21000000000 , &
- 6718.32000000000 , &
- 6713.42000000000 , &
- 6708.51000000000 , &
- 6703.57000000000 , &
- 6698.62000000000 , &
- 6693.66000000000 , &
- 6688.68000000000 , &
- 6683.68000000000 , &
- 6678.66000000000 , &
- 6673.63000000000 /)
-
- Mref_V%vsh_ref( 511 : 540 ) = (/ &
- 6668.58000000000 , &
- 6663.51000000000 , &
- 6658.43000000000 , &
- 6653.32000000000 , &
- 6648.20000000000 , &
- 6643.06000000000 , &
- 6637.90000000000 , &
- 6632.73000000000 , &
- 6627.53000000000 , &
- 6622.31000000000 , &
- 6617.08000000000 , &
- 6611.82000000000 , &
- 6606.55000000000 , &
- 6601.26000000000 , &
- 6595.94000000000 , &
- 6590.61000000000 , &
- 6584.91000000000 , &
- 6579.51000000000 , &
- 6574.11000000000 , &
- 6568.67000000000 , &
- 6563.22000000000 , &
- 6557.74000000000 , &
- 6552.24000000000 , &
- 6546.73000000000 , &
- 6541.19000000000 , &
- 6535.63000000000 , &
- 6530.05000000000 , &
- 6524.44000000000 , &
- 6518.82000000000 , &
- 6513.17000000000 /)
-
- Mref_V%vsh_ref( 541 : 570 ) = (/ &
- 6507.50000000000 , &
- 6501.80000000000 , &
- 6496.09000000000 , &
- 6490.35000000000 , &
- 6484.59000000000 , &
- 6478.80000000000 , &
- 6472.99000000000 , &
- 6467.16000000000 , &
- 6461.30000000000 , &
- 6455.42000000000 , &
- 6449.51000000000 , &
- 6443.58000000000 , &
- 6437.63000000000 , &
- 6431.65000000000 , &
- 6425.65000000000 , &
- 6419.61000000000 , &
- 6413.56000000000 , &
- 6407.48000000000 , &
- 6401.37000000000 , &
- 6395.25000000000 , &
- 6389.09000000000 , &
- 6382.91000000000 , &
- 6376.70000000000 , &
- 6370.46000000000 , &
- 6364.20000000000 , &
- 6357.91000000000 , &
- 6351.59000000000 , &
- 6345.25000000000 , &
- 6338.88000000000 , &
- 6332.49000000000 /)
-
- Mref_V%vsh_ref( 571 : 600 ) = (/ &
- 6326.05000000000 , &
- 6319.60000000000 , &
- 6313.13000000000 , &
- 6306.62000000000 , &
- 6300.08000000000 , &
- 6293.52000000000 , &
- 6286.92000000000 , &
- 6280.29000000000 , &
- 6273.64000000000 , &
- 6266.96000000000 , &
- 6260.25000000000 , &
- 6253.51000000000 , &
- 6246.75000000000 , &
- 6239.95000000000 , &
- 6239.95000000000 , &
- 6219.68000000000 , &
- 6200.29000000000 , &
- 6181.16000000000 , &
- 6162.04000000000 , &
- 6143.01000000000 , &
- 6123.98000000000 , &
- 6103.71000000000 , &
- 6083.53000000000 , &
- 6063.45000000000 , &
- 6043.44000000000 , &
- 6023.52000000000 , &
- 6003.73000000000 , &
- 5984.03000000000 , &
- 5964.38000000000 , &
- 5944.81000000000 /)
-
- Mref_V%vsh_ref( 601 : 630 ) = (/ &
- 5925.27000000000 , &
- 5550.32000000000 , &
- 5541.20000000000 , &
- 5532.08000000000 , &
- 5522.96000000000 , &
- 5513.83000000000 , &
- 5504.71000000000 , &
- 5495.59000000000 , &
- 5486.47000000000 , &
- 5477.35000000000 , &
- 5468.22000000000 , &
- 5459.10000000000 , &
- 5449.97000000000 , &
- 5440.84000000000 , &
- 5431.71000000000 , &
- 5422.57000000000 , &
- 5422.59000000000 , &
- 5406.39000000000 , &
- 5390.30000000000 , &
- 5374.34000000000 , &
- 5358.52000000000 , &
- 5342.83000000000 , &
- 5327.31000000000 , &
- 5311.92000000000 , &
- 5296.73000000000 , &
- 5281.71000000000 , &
- 5266.86000000000 , &
- 5252.21000000000 , &
- 5237.78000000000 , &
- 5223.55000000000 /)
-
- Mref_V%vsh_ref( 631 : 660 ) = (/ &
- 5209.54000000000 , &
- 5195.72000000000 , &
- 5182.10000000000 , &
- 5168.69000000000 , &
- 5155.42000000000 , &
- 5142.22000000000 , &
- 5129.05000000000 , &
- 5115.84000000000 , &
- 5102.55000000000 , &
- 5089.14000000000 , &
- 5075.50000000000 , &
- 5061.63000000000 , &
- 5047.46000000000 , &
- 5032.93000000000 , &
- 5018.03000000000 , &
- 5002.66000000000 , &
- 4986.77000000000 , &
- 4803.78000000000 , &
- 4800.54000000000 , &
- 4797.28000000000 , &
- 4793.96000000000 , &
- 4790.18000000000 , &
- 4785.78000000000 , &
- 4780.71000000000 , &
- 4775.00000000000 , &
- 4768.58000000000 , &
- 4761.41000000000 , &
- 4753.51000000000 , &
- 4744.86000000000 , &
- 4735.64000000000 /)
-
- Mref_V%vsh_ref( 661 : 690 ) = (/ &
- 4725.88000000000 , &
- 4715.76000000000 , &
- 4705.34000000000 , &
- 4694.74000000000 , &
- 4684.08000000000 , &
- 4673.46000000000 , &
- 4662.94000000000 , &
- 4652.61000000000 , &
- 4642.55000000000 , &
- 4632.81000000000 , &
- 4623.51000000000 , &
- 4614.68000000000 , &
- 4606.39000000000 , &
- 4598.73000000000 , &
- 4591.76000000000 , &
- 4585.56000000000 , &
- 4580.21000000000 , &
- 4575.75000000000 , &
- 4575.74000000000 , &
- 4572.27000000000 , &
- 4569.53000000000 , &
- 4567.46000000000 , &
- 4566.02000000000 , &
- 4565.10000000000 , &
- 4564.66000000000 , &
- 4564.65000000000 , &
- 4564.99000000000 , &
- 4565.62000000000 , &
- 4566.47000000000 , &
- 4567.46000000000 /)
-
- Mref_V%vsh_ref( 691 : 720 ) = (/ &
- 4568.58000000000 , &
- 4569.70000000000 , &
- 4570.85000000000 , &
- 4571.91000000000 , &
- 4572.83000000000 , &
- 4573.60000000000 , &
- 4574.16000000000 , &
- 4574.44000000000 , &
- 4574.42000000000 , &
- 4574.04000000000 , &
- 4573.36000000000 , &
- 4572.41000000000 , &
- 4572.46000000000 , &
- 4571.71000000000 , &
- 4570.93000000000 , &
- 4570.06000000000 , &
- 4569.16000000000 , &
- 4568.21000000000 , &
- 4567.22000000000 , &
- 4566.21000000000 , &
- 4565.16000000000 , &
- 4564.11000000000 , &
- 4563.05000000000 , &
- 4562.00000000000 , &
- 4560.94000000000 , &
- 4559.94000000000 , &
- 4558.94000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 /)
-
- Mref_V%vsh_ref( 721 : 750 ) = (/ &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3900.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 , &
- 3200.00000000000 /)
-
- Mref_V%eta_ref( 1 : 30 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 31 : 60 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 61 : 90 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 91 : 120 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 121 : 150 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 151 : 180 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 181 : 210 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 211 : 240 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 241 : 270 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 271 : 300 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 301 : 330 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 331 : 360 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 361 : 390 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 391 : 420 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 421 : 450 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 451 : 480 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 481 : 510 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 511 : 540 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 541 : 570 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 571 : 600 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 601 : 630 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 631 : 660 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 0.999990000000000 , &
- 0.999970000000000 , &
- 0.999950000000000 , &
- 0.999940000000000 , &
- 0.999900000000000 , &
- 0.999860000000000 , &
- 0.999800000000000 , &
- 0.999740000000000 , &
- 0.999660000000000 /)
-
- Mref_V%eta_ref( 661 : 690 ) = (/ &
- 0.999570000000000 , &
- 0.999470000000000 , &
- 0.999340000000000 , &
- 0.999200000000000 , &
- 0.999040000000000 , &
- 0.998860000000000 , &
- 0.998640000000000 , &
- 0.998320000000000 , &
- 0.997900000000000 , &
- 0.997320000000000 , &
- 0.996540000000000 , &
- 0.995530000000000 , &
- 0.994260000000000 , &
- 0.992680000000000 , &
- 0.990750000000000 , &
- 0.988430000000000 , &
- 0.985710000000000 , &
- 0.982550000000000 , &
- 0.982500000000000 , &
- 0.979070000000000 , &
- 0.975310000000000 , &
- 0.971280000000000 , &
- 0.967040000000000 , &
- 0.962680000000000 , &
- 0.958230000000000 , &
- 0.953780000000000 , &
- 0.949380000000000 , &
- 0.945090000000000 , &
- 0.940980000000000 , &
- 0.937120000000000 /)
-
- Mref_V%eta_ref( 691 : 720 ) = (/ &
- 0.933560000000000 , &
- 0.930340000000000 , &
- 0.927430000000000 , &
- 0.924830000000000 , &
- 0.922510000000000 , &
- 0.920460000000000 , &
- 0.918670000000000 , &
- 0.917110000000000 , &
- 0.915770000000000 , &
- 0.914650000000000 , &
- 0.913710000000000 , &
- 0.912960000000000 , &
- 0.912940000000000 , &
- 0.912540000000000 , &
- 0.912210000000000 , &
- 0.911930000000000 , &
- 0.911710000000000 , &
- 0.911550000000000 , &
- 0.911420000000000 , &
- 0.911340000000000 , &
- 0.911300000000000 , &
- 0.911290000000000 , &
- 0.911300000000000 , &
- 0.911350000000000 , &
- 0.911400000000000 , &
- 0.911470000000000 , &
- 0.911550000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- Mref_V%eta_ref( 721 : 750 ) = (/ &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 , &
- 1.00000000000000 /)
-
- if (SUPPRESS_CRUSTAL_MESH) then
- Mref_V%density_ref(718:750) = Mref_V%density_ref(717)
- Mref_V%vpv_ref(718:750) = Mref_V%vpv_ref(717)
- Mref_V%vph_ref(718:750) = Mref_V%vph_ref(717)
- Mref_V%vsv_ref(718:750) = Mref_V%vsv_ref(717)
- Mref_V%vsh_ref(718:750) = Mref_V%vsh_ref(717)
- endif
-
-
- end subroutine define_model_ref
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_sea1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_sea1d.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_sea1d.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,1144 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 model_sea1d(x,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
-
- implicit none
-
- include "constants.h"
-
-! 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
-
-! input:
-! radius r: meters
-
-! output:
-! density rho: kg/m^3
-! compressional wave speed vp: km/s
-! shear wave speed vs: km/s
-
- integer iregion_code
-
- double precision x,rho,vp,vs,Qmu,Qkappa
-
- integer i
-
- double precision r,frac,scaleval
-
-!! DK DK UGLY implementation of model sea1d below and its radii in
-!! DK DK UGLY subroutine read_parameter_file.f90 has not been thoroughly
-!! DK DK UGLY checked yet
-
-! compute real physical radius in meters
- r = x * R_EARTH
-
- i = 1
- do while(r >= SEA1DM_V%radius_sea1d(i) .and. i /= NR_SEA1D)
- i = i + 1
- enddo
-
-! make sure we stay in the right region
- if(iregion_code == IREGION_INNER_CORE .and. i > 13) i = 13
-
- if(iregion_code == IREGION_OUTER_CORE .and. i < 15) i = 15
- if(iregion_code == IREGION_OUTER_CORE .and. i > 37) i = 37
-
- if(iregion_code == IREGION_CRUST_MANTLE .and. i < 39) i = 39
-
- if(i == 1) then
- rho = SEA1DM_V%density_sea1d(i)
- vp = SEA1DM_V%vp_sea1d(i)
- vs = SEA1DM_V%vs_sea1d(i)
- Qmu = SEA1DM_V%Qmu_sea1d(i)
- Qkappa = SEA1DM_V%Qkappa_sea1d(i)
- else
-
-! interpolate from SEA1DM_V%radius_sea1d(i-1) to r using the values at i-1 and i
- frac = (r-SEA1DM_V%radius_sea1d(i-1))/(SEA1DM_V%radius_sea1d(i)-SEA1DM_V%radius_sea1d(i-1))
-
- rho = SEA1DM_V%density_sea1d(i-1) + frac * (SEA1DM_V%density_sea1d(i)-SEA1DM_V%density_sea1d(i-1))
- vp = SEA1DM_V%vp_sea1d(i-1) + frac * (SEA1DM_V%vp_sea1d(i)-SEA1DM_V%vp_sea1d(i-1))
- vs = SEA1DM_V%vs_sea1d(i-1) + frac * (SEA1DM_V%vs_sea1d(i)-SEA1DM_V%vs_sea1d(i-1))
- Qmu = SEA1DM_V%Qmu_sea1d(i-1) + frac * (SEA1DM_V%Qmu_sea1d(i)-SEA1DM_V%Qmu_sea1d(i-1))
- Qkappa = SEA1DM_V%Qkappa_sea1d(i-1) + frac * (SEA1DM_V%Qkappa_sea1d(i)-SEA1DM_V%Qkappa_sea1d(i-1))
-
- endif
-
-! make sure Vs is zero in the outer core even if roundoff errors on depth
-! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
- if(iregion_code == IREGION_OUTER_CORE) then
- vs = 0.d0
- Qkappa = 3000.d0
- Qmu = 3000.d0
- endif
-
-! non-dimensionalize
-! time scaling (s^{-1}) is done with scaleval
- scaleval=dsqrt(PI*GRAV*RHOAV)
- rho=rho*1000.0d0/RHOAV
- vp=vp*1000.0d0/(R_EARTH*scaleval)
- vs=vs*1000.0d0/(R_EARTH*scaleval)
-
- end subroutine model_sea1d
-
-!-------------------
-
- subroutine define_model_sea1d(USE_EXTERNAL_CRUSTAL_MODEL,SEA1DM_V)
-
- implicit none
-
- include "constants.h"
-
-! 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
-! three_d_mantle_model_variables
-
- logical USE_EXTERNAL_CRUSTAL_MODEL
-
- integer i
-
-! define all the values in the model
-
- SEA1DM_V%radius_sea1d(1)= 0.0000000000
- SEA1DM_V%radius_sea1d(2)= 101425.0000000000
- SEA1DM_V%radius_sea1d(3)= 202850.0000000000
- SEA1DM_V%radius_sea1d(4)= 304275.0000000000
- SEA1DM_V%radius_sea1d(5)= 405700.0000000000
- SEA1DM_V%radius_sea1d(6)= 507125.0000000000
- SEA1DM_V%radius_sea1d(7)= 608550.0000000000
- SEA1DM_V%radius_sea1d(8)= 709975.0000000000
- SEA1DM_V%radius_sea1d(9)= 811400.0000000000
- SEA1DM_V%radius_sea1d(10)= 912825.0000000000
- SEA1DM_V%radius_sea1d(11)= 1014250.0000000000
- SEA1DM_V%radius_sea1d(12)= 1115675.0000000000
- SEA1DM_V%radius_sea1d(13)= 1217100.0000000000
- SEA1DM_V%radius_sea1d(14)= 1217100.0000000000
- SEA1DM_V%radius_sea1d(15)= 1315735.0000000000
- SEA1DM_V%radius_sea1d(16)= 1414370.0000000000
- SEA1DM_V%radius_sea1d(17)= 1513004.0000000000
- SEA1DM_V%radius_sea1d(18)= 1611639.0000000000
- SEA1DM_V%radius_sea1d(19)= 1710274.0000000000
- SEA1DM_V%radius_sea1d(20)= 1808909.0000000000
- SEA1DM_V%radius_sea1d(21)= 1907544.0000000000
- SEA1DM_V%radius_sea1d(22)= 2006178.0000000000
- SEA1DM_V%radius_sea1d(23)= 2104813.0000000000
- SEA1DM_V%radius_sea1d(24)= 2203448.0000000000
- SEA1DM_V%radius_sea1d(25)= 2302082.0000000000
- SEA1DM_V%radius_sea1d(26)= 2400717.0000000000
- SEA1DM_V%radius_sea1d(27)= 2499352.0000000000
- SEA1DM_V%radius_sea1d(28)= 2597987.0000000000
- SEA1DM_V%radius_sea1d(29)= 2696622.0000000000
- SEA1DM_V%radius_sea1d(30)= 2795256.0000000000
- SEA1DM_V%radius_sea1d(31)= 2893891.0000000000
- SEA1DM_V%radius_sea1d(32)= 2992526.0000000000
- SEA1DM_V%radius_sea1d(33)= 3091161.0000000000
- SEA1DM_V%radius_sea1d(34)= 3189796.0000000000
- SEA1DM_V%radius_sea1d(35)= 3288431.0000000000
- SEA1DM_V%radius_sea1d(36)= 3387066.0000000000
- SEA1DM_V%radius_sea1d(37)= 3485700.0000000000
- SEA1DM_V%radius_sea1d(38)= 3485700.0000000000
- SEA1DM_V%radius_sea1d(39)= 3536048.0000000000
- SEA1DM_V%radius_sea1d(40)= 3586396.0000000000
- SEA1DM_V%radius_sea1d(41)= 3636743.0000000000
- SEA1DM_V%radius_sea1d(42)= 3687091.0000000000
- SEA1DM_V%radius_sea1d(43)= 3737438.0000000000
- SEA1DM_V%radius_sea1d(44)= 3787786.0000000000
- SEA1DM_V%radius_sea1d(45)= 3838134.0000000000
- SEA1DM_V%radius_sea1d(46)= 3888482.0000000000
- SEA1DM_V%radius_sea1d(47)= 3938830.0000000000
- SEA1DM_V%radius_sea1d(48)= 3989177.0000000000
- SEA1DM_V%radius_sea1d(49)= 4039525.0000000000
- SEA1DM_V%radius_sea1d(50)= 4089872.0000000000
- SEA1DM_V%radius_sea1d(51)= 4140220.0000000000
- SEA1DM_V%radius_sea1d(52)= 4190568.0000000000
- SEA1DM_V%radius_sea1d(53)= 4240916.0000000000
- SEA1DM_V%radius_sea1d(54)= 4291264.0000000000
- SEA1DM_V%radius_sea1d(55)= 4341612.0000000000
- SEA1DM_V%radius_sea1d(56)= 4391959.0000000000
- SEA1DM_V%radius_sea1d(57)= 4442306.0000000000
- SEA1DM_V%radius_sea1d(58)= 4492654.0000000000
- SEA1DM_V%radius_sea1d(59)= 4543002.0000000000
- SEA1DM_V%radius_sea1d(60)= 4593350.0000000000
- SEA1DM_V%radius_sea1d(61)= 4643698.0000000000
- SEA1DM_V%radius_sea1d(62)= 4694046.0000000000
- SEA1DM_V%radius_sea1d(63)= 4744393.0000000000
- SEA1DM_V%radius_sea1d(64)= 4794740.0000000000
- SEA1DM_V%radius_sea1d(65)= 4845089.0000000000
- SEA1DM_V%radius_sea1d(66)= 4895436.0000000000
- SEA1DM_V%radius_sea1d(67)= 4945784.0000000000
- SEA1DM_V%radius_sea1d(68)= 4996132.0000000000
- SEA1DM_V%radius_sea1d(69)= 5046480.0000000000
- SEA1DM_V%radius_sea1d(70)= 5096827.0000000000
- SEA1DM_V%radius_sea1d(71)= 5147175.0000000000
- SEA1DM_V%radius_sea1d(72)= 5197522.0000000000
- SEA1DM_V%radius_sea1d(73)= 5247870.0000000000
- SEA1DM_V%radius_sea1d(74)= 5298218.0000000000
- SEA1DM_V%radius_sea1d(75)= 5348566.0000000000
- SEA1DM_V%radius_sea1d(76)= 5398914.0000000000
- SEA1DM_V%radius_sea1d(77)= 5449261.0000000000
- SEA1DM_V%radius_sea1d(78)= 5499610.0000000000
- SEA1DM_V%radius_sea1d(79)= 5549957.0000000000
- SEA1DM_V%radius_sea1d(80)= 5600304.0000000000
- SEA1DM_V%radius_sea1d(81)= 5650652.0000000000
- SEA1DM_V%radius_sea1d(82)= 5701000.0000000000
- SEA1DM_V%radius_sea1d(83)= 5711000.0000000000
- SEA1DM_V%radius_sea1d(84)= 5711000.0000000000
- SEA1DM_V%radius_sea1d(85)= 5721000.0000000000
- SEA1DM_V%radius_sea1d(86)= 5731000.0000000000
- SEA1DM_V%radius_sea1d(87)= 5741000.0000000000
- SEA1DM_V%radius_sea1d(88)= 5751000.0000000000
- SEA1DM_V%radius_sea1d(89)= 5761000.0000000000
- SEA1DM_V%radius_sea1d(90)= 5771000.0000000000
- SEA1DM_V%radius_sea1d(91)= 5781000.0000000000
- SEA1DM_V%radius_sea1d(92)= 5791000.0000000000
- SEA1DM_V%radius_sea1d(93)= 5801000.0000000000
- SEA1DM_V%radius_sea1d(94)= 5811000.0000000000
- SEA1DM_V%radius_sea1d(95)= 5821000.0000000000
- SEA1DM_V%radius_sea1d(96)= 5831000.0000000000
- SEA1DM_V%radius_sea1d(97)= 5841000.0000000000
- SEA1DM_V%radius_sea1d(98)= 5851000.0000000000
- SEA1DM_V%radius_sea1d(99)= 5861000.0000000000
- SEA1DM_V%radius_sea1d(100)= 5871000.0000000000
- SEA1DM_V%radius_sea1d(101)= 5881000.0000000000
- SEA1DM_V%radius_sea1d(102)= 5891000.0000000000
- SEA1DM_V%radius_sea1d(103)= 5901000.0000000000
- SEA1DM_V%radius_sea1d(104)= 5911000.0000000000
- SEA1DM_V%radius_sea1d(105)= 5921000.0000000000
- SEA1DM_V%radius_sea1d(106)= 5931000.0000000000
- SEA1DM_V%radius_sea1d(107)= 5941000.0000000000
- SEA1DM_V%radius_sea1d(108)= 5951000.0000000000
- SEA1DM_V%radius_sea1d(109)= 5961000.0000000000
- SEA1DM_V%radius_sea1d(110)= 5961000.0000000000
- SEA1DM_V%radius_sea1d(111)= 5971000.0000000000
- SEA1DM_V%radius_sea1d(112)= 5981000.0000000000
- SEA1DM_V%radius_sea1d(113)= 5991000.0000000000
- SEA1DM_V%radius_sea1d(114)= 6001000.0000000000
- SEA1DM_V%radius_sea1d(115)= 6011000.0000000000
- SEA1DM_V%radius_sea1d(116)= 6021000.0000000000
- SEA1DM_V%radius_sea1d(117)= 6031000.0000000000
- SEA1DM_V%radius_sea1d(118)= 6041000.0000000000
- SEA1DM_V%radius_sea1d(119)= 6051000.0000000000
- SEA1DM_V%radius_sea1d(120)= 6061000.0000000000
- SEA1DM_V%radius_sea1d(121)= 6071000.0000000000
- SEA1DM_V%radius_sea1d(122)= 6081000.0000000000
- SEA1DM_V%radius_sea1d(123)= 6091000.0000000000
- SEA1DM_V%radius_sea1d(124)= 6101000.0000000000
- SEA1DM_V%radius_sea1d(125)= 6111000.0000000000
- SEA1DM_V%radius_sea1d(126)= 6121000.0000000000
- SEA1DM_V%radius_sea1d(127)= 6131000.0000000000
- SEA1DM_V%radius_sea1d(128)= 6141000.0000000000
- SEA1DM_V%radius_sea1d(129)= 6151000.0000000000
- SEA1DM_V%radius_sea1d(130)= 6161000.0000000000
- SEA1DM_V%radius_sea1d(131)= 6171000.0000000000
- SEA1DM_V%radius_sea1d(132)= 6181000.0000000000
- SEA1DM_V%radius_sea1d(133)= 6191000.0000000000
- SEA1DM_V%radius_sea1d(134)= 6201000.0000000000
- SEA1DM_V%radius_sea1d(135)= 6211000.0000000000
- SEA1DM_V%radius_sea1d(136)= 6221000.0000000000
- SEA1DM_V%radius_sea1d(137)= 6231000.0000000000
- SEA1DM_V%radius_sea1d(138)= 6241000.0000000000
- SEA1DM_V%radius_sea1d(139)= 6251000.0000000000
- SEA1DM_V%radius_sea1d(140)= 6261000.0000000000
- SEA1DM_V%radius_sea1d(141)= 6271000.0000000000
- SEA1DM_V%radius_sea1d(142)= 6281000.0000000000
- SEA1DM_V%radius_sea1d(143)= 6291000.0000000000
- SEA1DM_V%radius_sea1d(144)= 6301000.0000000000
- SEA1DM_V%radius_sea1d(145)= 6311000.0000000000
- SEA1DM_V%radius_sea1d(146)= 6321000.0000000000
- SEA1DM_V%radius_sea1d(147)= 6326000.0000000000
- SEA1DM_V%radius_sea1d(148)= 6331000.0000000000
- SEA1DM_V%radius_sea1d(149)= 6336000.0000000000
- SEA1DM_V%radius_sea1d(150)= 6341000.0000000000
- SEA1DM_V%radius_sea1d(151)= 6346000.0000000000
- SEA1DM_V%radius_sea1d(152)= 6346000.0000000000
- SEA1DM_V%radius_sea1d(153)= 6351000.0000000000
- SEA1DM_V%radius_sea1d(154)= 6353800.0000000000
- SEA1DM_V%radius_sea1d(155)= 6356600.0000000000
- SEA1DM_V%radius_sea1d(156)= 6360000.0000000000
- SEA1DM_V%radius_sea1d(157)= 6363000.0000000000
- SEA1DM_V%radius_sea1d(158)= 6365000.0000000000
- SEA1DM_V%radius_sea1d(159)= 6366000.0000000000
- SEA1DM_V%radius_sea1d(160)= 6366000.0000000000
- SEA1DM_V%radius_sea1d(161)= 6368000.0000000000
- SEA1DM_V%radius_sea1d(162)= 6368000.0000000000
- SEA1DM_V%radius_sea1d(163)= 6371000.0000000000
-
- SEA1DM_V%density_sea1d(1)= 13.0121900000000
- SEA1DM_V%density_sea1d(2)= 13.0100200000000
- SEA1DM_V%density_sea1d(3)= 13.0035600000000
- SEA1DM_V%density_sea1d(4)= 12.9928300000000
- SEA1DM_V%density_sea1d(5)= 12.9778000000000
- SEA1DM_V%density_sea1d(6)= 12.9585000000000
- SEA1DM_V%density_sea1d(7)= 12.9349100000000
- SEA1DM_V%density_sea1d(8)= 12.9070300000000
- SEA1DM_V%density_sea1d(9)= 12.8748700000000
- SEA1DM_V%density_sea1d(10)= 12.8384300000000
- SEA1DM_V%density_sea1d(11)= 12.7977100000000
- SEA1DM_V%density_sea1d(12)= 12.7526900000000
- SEA1DM_V%density_sea1d(13)= 12.7037000000000
- SEA1DM_V%density_sea1d(14)= 12.1391000000000
- SEA1DM_V%density_sea1d(15)= 12.0877600000000
- SEA1DM_V%density_sea1d(16)= 12.0333900000000
- SEA1DM_V%density_sea1d(17)= 11.9757900000000
- SEA1DM_V%density_sea1d(18)= 11.9148500000000
- SEA1DM_V%density_sea1d(19)= 11.8503900000000
- SEA1DM_V%density_sea1d(20)= 11.7822500000000
- SEA1DM_V%density_sea1d(21)= 11.7102700000000
- SEA1DM_V%density_sea1d(22)= 11.6343000000000
- SEA1DM_V%density_sea1d(23)= 11.5541800000000
- SEA1DM_V%density_sea1d(24)= 11.4697400000000
- SEA1DM_V%density_sea1d(25)= 11.3808400000000
- SEA1DM_V%density_sea1d(26)= 11.2873100000000
- SEA1DM_V%density_sea1d(27)= 11.1890000000000
- SEA1DM_V%density_sea1d(28)= 11.0857400000000
- SEA1DM_V%density_sea1d(29)= 10.9773800000000
- SEA1DM_V%density_sea1d(30)= 10.8637600000000
- SEA1DM_V%density_sea1d(31)= 10.7447200000000
- SEA1DM_V%density_sea1d(32)= 10.6201000000000
- SEA1DM_V%density_sea1d(33)= 10.4897500000000
- SEA1DM_V%density_sea1d(34)= 10.3535000000000
- SEA1DM_V%density_sea1d(35)= 10.2112100000000
- SEA1DM_V%density_sea1d(36)= 10.0627000000000
- SEA1DM_V%density_sea1d(37)= 9.9085500000000
- SEA1DM_V%density_sea1d(38)= 5.5497800000000
- SEA1DM_V%density_sea1d(39)= 5.5263200000000
- SEA1DM_V%density_sea1d(40)= 5.5027000000000
- SEA1DM_V%density_sea1d(41)= 5.4789400000000
- SEA1DM_V%density_sea1d(42)= 5.4550400000000
- SEA1DM_V%density_sea1d(43)= 5.4309700000000
- SEA1DM_V%density_sea1d(44)= 5.4067700000000
- SEA1DM_V%density_sea1d(45)= 5.3824200000000
- SEA1DM_V%density_sea1d(46)= 5.3579200000000
- SEA1DM_V%density_sea1d(47)= 5.3332700000000
- SEA1DM_V%density_sea1d(48)= 5.3084700000000
- SEA1DM_V%density_sea1d(49)= 5.2835200000000
- SEA1DM_V%density_sea1d(50)= 5.2584400000000
- SEA1DM_V%density_sea1d(51)= 5.2331900000000
- SEA1DM_V%density_sea1d(52)= 5.2078000000000
- SEA1DM_V%density_sea1d(53)= 5.1822700000000
- SEA1DM_V%density_sea1d(54)= 5.1565900000000
- SEA1DM_V%density_sea1d(55)= 5.1307500000000
- SEA1DM_V%density_sea1d(56)= 5.1047600000000
- SEA1DM_V%density_sea1d(57)= 5.0786400000000
- SEA1DM_V%density_sea1d(58)= 5.0523600000000
- SEA1DM_V%density_sea1d(59)= 5.0259400000000
- SEA1DM_V%density_sea1d(60)= 4.9993600000000
- SEA1DM_V%density_sea1d(61)= 4.9726500000000
- SEA1DM_V%density_sea1d(62)= 4.9457800000000
- SEA1DM_V%density_sea1d(63)= 4.9187500000000
- SEA1DM_V%density_sea1d(64)= 4.8915900000000
- SEA1DM_V%density_sea1d(65)= 4.8642700000000
- SEA1DM_V%density_sea1d(66)= 4.8368200000000
- SEA1DM_V%density_sea1d(67)= 4.8092100000000
- SEA1DM_V%density_sea1d(68)= 4.7814400000000
- SEA1DM_V%density_sea1d(69)= 4.7535400000000
- SEA1DM_V%density_sea1d(70)= 4.7254900000000
- SEA1DM_V%density_sea1d(71)= 4.6972900000000
- SEA1DM_V%density_sea1d(72)= 4.6689400000000
- SEA1DM_V%density_sea1d(73)= 4.6404400000000
- SEA1DM_V%density_sea1d(74)= 4.6117900000000
- SEA1DM_V%density_sea1d(75)= 4.5830000000000
- SEA1DM_V%density_sea1d(76)= 4.5540600000000
- SEA1DM_V%density_sea1d(77)= 4.5249700000000
- SEA1DM_V%density_sea1d(78)= 4.4957300000000
- SEA1DM_V%density_sea1d(79)= 4.4663500000000
- SEA1DM_V%density_sea1d(80)= 4.4368100000000
- SEA1DM_V%density_sea1d(81)= 4.4071300000000
- SEA1DM_V%density_sea1d(82)= 4.3773100000000
- SEA1DM_V%density_sea1d(83)= 4.3713900000000
- SEA1DM_V%density_sea1d(84)= 4.0645800000000
- SEA1DM_V%density_sea1d(85)= 4.0522200000000
- SEA1DM_V%density_sea1d(86)= 4.0398700000000
- SEA1DM_V%density_sea1d(87)= 4.0275200000000
- SEA1DM_V%density_sea1d(88)= 4.0151600000000
- SEA1DM_V%density_sea1d(89)= 4.0028100000000
- SEA1DM_V%density_sea1d(90)= 3.9904500000000
- SEA1DM_V%density_sea1d(91)= 3.9781000000000
- SEA1DM_V%density_sea1d(92)= 3.9657500000000
- SEA1DM_V%density_sea1d(93)= 3.9533900000000
- SEA1DM_V%density_sea1d(94)= 3.9410400000000
- SEA1DM_V%density_sea1d(95)= 3.9286900000000
- SEA1DM_V%density_sea1d(96)= 3.9163300000000
- SEA1DM_V%density_sea1d(97)= 3.9039800000000
- SEA1DM_V%density_sea1d(98)= 3.8916200000000
- SEA1DM_V%density_sea1d(99)= 3.8792700000000
- SEA1DM_V%density_sea1d(100)= 3.8669200000000
- SEA1DM_V%density_sea1d(101)= 3.8545600000000
- SEA1DM_V%density_sea1d(102)= 3.8422100000000
- SEA1DM_V%density_sea1d(103)= 3.8298600000000
- SEA1DM_V%density_sea1d(104)= 3.8175000000000
- SEA1DM_V%density_sea1d(105)= 3.8051500000000
- SEA1DM_V%density_sea1d(106)= 3.7928000000000
- SEA1DM_V%density_sea1d(107)= 3.7804400000000
- SEA1DM_V%density_sea1d(108)= 3.7680900000000
- SEA1DM_V%density_sea1d(109)= 3.7557300000000
- SEA1DM_V%density_sea1d(110)= 3.5469600000000
- SEA1DM_V%density_sea1d(111)= 3.5409000000000
- SEA1DM_V%density_sea1d(112)= 3.5348400000000
- SEA1DM_V%density_sea1d(113)= 3.5287900000000
- SEA1DM_V%density_sea1d(114)= 3.5227300000000
- SEA1DM_V%density_sea1d(115)= 3.5166700000000
- SEA1DM_V%density_sea1d(116)= 3.5106100000000
- SEA1DM_V%density_sea1d(117)= 3.5045500000000
- SEA1DM_V%density_sea1d(118)= 3.4984900000000
- SEA1DM_V%density_sea1d(119)= 3.4924300000000
- SEA1DM_V%density_sea1d(120)= 3.4863800000000
- SEA1DM_V%density_sea1d(121)= 3.4803200000000
- SEA1DM_V%density_sea1d(122)= 3.4742600000000
- SEA1DM_V%density_sea1d(123)= 3.4682000000000
- SEA1DM_V%density_sea1d(124)= 3.4621400000000
- SEA1DM_V%density_sea1d(125)= 3.4560800000000
- SEA1DM_V%density_sea1d(126)= 3.4500200000000
- SEA1DM_V%density_sea1d(127)= 3.4439700000000
- SEA1DM_V%density_sea1d(128)= 3.4379100000000
- SEA1DM_V%density_sea1d(129)= 3.4318500000000
- SEA1DM_V%density_sea1d(130)= 3.4257900000000
- SEA1DM_V%density_sea1d(131)= 3.4197300000000
- SEA1DM_V%density_sea1d(132)= 3.4136800000000
- SEA1DM_V%density_sea1d(133)= 3.4076200000000
- SEA1DM_V%density_sea1d(134)= 3.4015600000000
- SEA1DM_V%density_sea1d(135)= 3.3955000000000
- SEA1DM_V%density_sea1d(136)= 3.3894400000000
- SEA1DM_V%density_sea1d(137)= 3.3833800000000
- SEA1DM_V%density_sea1d(138)= 3.3773200000000
- SEA1DM_V%density_sea1d(139)= 3.3712600000000
- SEA1DM_V%density_sea1d(140)= 3.3652100000000
- SEA1DM_V%density_sea1d(141)= 3.3591500000000
- SEA1DM_V%density_sea1d(142)= 3.3530900000000
- SEA1DM_V%density_sea1d(143)= 3.3470300000000
- SEA1DM_V%density_sea1d(144)= 3.3409700000000
- SEA1DM_V%density_sea1d(145)= 3.3349100000000
- SEA1DM_V%density_sea1d(146)= 3.3288500000000
- SEA1DM_V%density_sea1d(147)= 3.3288500000000
- SEA1DM_V%density_sea1d(148)= 3.3227900000000
- SEA1DM_V%density_sea1d(149)= 3.3227900000000
- SEA1DM_V%density_sea1d(150)= 3.3227900000000
- SEA1DM_V%density_sea1d(151)= 3.3227900000000
- SEA1DM_V%density_sea1d(152)= 2.8500000000000
- SEA1DM_V%density_sea1d(153)= 2.8500000000000
- SEA1DM_V%density_sea1d(154)= 2.8500000000000
- SEA1DM_V%density_sea1d(155)= 2.8500000000000
- SEA1DM_V%density_sea1d(156)= 2.8500000000000
- SEA1DM_V%density_sea1d(157)= 2.8500000000000
- SEA1DM_V%density_sea1d(158)= 2.8500000000000
- SEA1DM_V%density_sea1d(159)= 2.8500000000000
- SEA1DM_V%density_sea1d(160)= 2.8500000000000
- SEA1DM_V%density_sea1d(161)= 2.8500000000000
- SEA1DM_V%density_sea1d(162)= 2.8500000000000
- SEA1DM_V%density_sea1d(163)= 2.8500000000000
-
- SEA1DM_V%vp_sea1d(1)= 11.2409400000000
- SEA1DM_V%vp_sea1d(2)= 11.2398900000000
- SEA1DM_V%vp_sea1d(3)= 11.2367600000000
- SEA1DM_V%vp_sea1d(4)= 11.2315600000000
- SEA1DM_V%vp_sea1d(5)= 11.2242700000000
- SEA1DM_V%vp_sea1d(6)= 11.2149200000000
- SEA1DM_V%vp_sea1d(7)= 11.2034800000000
- SEA1DM_V%vp_sea1d(8)= 11.1899700000000
- SEA1DM_V%vp_sea1d(9)= 11.1743800000000
- SEA1DM_V%vp_sea1d(10)= 11.1567200000000
- SEA1DM_V%vp_sea1d(11)= 11.1369900000000
- SEA1DM_V%vp_sea1d(12)= 11.1151700000000
- SEA1DM_V%vp_sea1d(13)= 11.0914200000000
- SEA1DM_V%vp_sea1d(14)= 10.2577900000000
- SEA1DM_V%vp_sea1d(15)= 10.2317700000000
- SEA1DM_V%vp_sea1d(16)= 10.1991900000000
- SEA1DM_V%vp_sea1d(17)= 10.1600600000000
- SEA1DM_V%vp_sea1d(18)= 10.1143700000000
- SEA1DM_V%vp_sea1d(19)= 10.0621400000000
- SEA1DM_V%vp_sea1d(20)= 10.0033600000000
- SEA1DM_V%vp_sea1d(21)= 9.9380100000000
- SEA1DM_V%vp_sea1d(22)= 9.8661300000000
- SEA1DM_V%vp_sea1d(23)= 9.7876800000000
- SEA1DM_V%vp_sea1d(24)= 9.7026900000000
- SEA1DM_V%vp_sea1d(25)= 9.6111500000000
- SEA1DM_V%vp_sea1d(26)= 9.5130500000000
- SEA1DM_V%vp_sea1d(27)= 9.4084000000000
- SEA1DM_V%vp_sea1d(28)= 9.2972000000000
- SEA1DM_V%vp_sea1d(29)= 9.1794500000000
- SEA1DM_V%vp_sea1d(30)= 9.0551400000000
- SEA1DM_V%vp_sea1d(31)= 8.9242800000000
- SEA1DM_V%vp_sea1d(32)= 8.7868700000000
- SEA1DM_V%vp_sea1d(33)= 8.6429000000000
- SEA1DM_V%vp_sea1d(34)= 8.4923900000000
- SEA1DM_V%vp_sea1d(35)= 8.3353300000000
- SEA1DM_V%vp_sea1d(36)= 8.1717000000000
- SEA1DM_V%vp_sea1d(37)= 8.0022600000000
- SEA1DM_V%vp_sea1d(38)= 13.7318200000000
- SEA1DM_V%vp_sea1d(39)= 13.6839600000000
- SEA1DM_V%vp_sea1d(40)= 13.6355700000000
- SEA1DM_V%vp_sea1d(41)= 13.5866700000000
- SEA1DM_V%vp_sea1d(42)= 13.5372000000000
- SEA1DM_V%vp_sea1d(43)= 13.4871700000000
- SEA1DM_V%vp_sea1d(44)= 13.4365700000000
- SEA1DM_V%vp_sea1d(45)= 13.3853700000000
- SEA1DM_V%vp_sea1d(46)= 13.3335400000000
- SEA1DM_V%vp_sea1d(47)= 13.2811000000000
- SEA1DM_V%vp_sea1d(48)= 13.2280100000000
- SEA1DM_V%vp_sea1d(49)= 13.1742700000000
- SEA1DM_V%vp_sea1d(50)= 13.1198500000000
- SEA1DM_V%vp_sea1d(51)= 13.0647300000000
- SEA1DM_V%vp_sea1d(52)= 13.0089100000000
- SEA1DM_V%vp_sea1d(53)= 12.9523700000000
- SEA1DM_V%vp_sea1d(54)= 12.8951000000000
- SEA1DM_V%vp_sea1d(55)= 12.8370600000000
- SEA1DM_V%vp_sea1d(56)= 12.7782600000000
- SEA1DM_V%vp_sea1d(57)= 12.7186700000000
- SEA1DM_V%vp_sea1d(58)= 12.6582800000000
- SEA1DM_V%vp_sea1d(59)= 12.5970700000000
- SEA1DM_V%vp_sea1d(60)= 12.5350400000000
- SEA1DM_V%vp_sea1d(61)= 12.4721600000000
- SEA1DM_V%vp_sea1d(62)= 12.4084000000000
- SEA1DM_V%vp_sea1d(63)= 12.3437700000000
- SEA1DM_V%vp_sea1d(64)= 12.2782500000000
- SEA1DM_V%vp_sea1d(65)= 12.2118200000000
- SEA1DM_V%vp_sea1d(66)= 12.1444600000000
- SEA1DM_V%vp_sea1d(67)= 12.0761600000000
- SEA1DM_V%vp_sea1d(68)= 12.0069000000000
- SEA1DM_V%vp_sea1d(69)= 11.9366700000000
- SEA1DM_V%vp_sea1d(70)= 11.8654400000000
- SEA1DM_V%vp_sea1d(71)= 11.7932100000000
- SEA1DM_V%vp_sea1d(72)= 11.7199700000000
- SEA1DM_V%vp_sea1d(73)= 11.6456800000000
- SEA1DM_V%vp_sea1d(74)= 11.5703400000000
- SEA1DM_V%vp_sea1d(75)= 11.4939400000000
- SEA1DM_V%vp_sea1d(76)= 11.4164500000000
- SEA1DM_V%vp_sea1d(77)= 11.3378700000000
- SEA1DM_V%vp_sea1d(78)= 11.2581700000000
- SEA1DM_V%vp_sea1d(79)= 11.1773300000000
- SEA1DM_V%vp_sea1d(80)= 11.0953600000000
- SEA1DM_V%vp_sea1d(81)= 11.0122200000000
- SEA1DM_V%vp_sea1d(82)= 10.9280200000000
- SEA1DM_V%vp_sea1d(83)= 10.9113000000000
- SEA1DM_V%vp_sea1d(84)= 10.0182900000000
- SEA1DM_V%vp_sea1d(85)= 9.9989600000000
- SEA1DM_V%vp_sea1d(86)= 9.9796300000000
- SEA1DM_V%vp_sea1d(87)= 9.9603000000000
- SEA1DM_V%vp_sea1d(88)= 9.9409700000000
- SEA1DM_V%vp_sea1d(89)= 9.9216400000000
- SEA1DM_V%vp_sea1d(90)= 9.9023100000000
- SEA1DM_V%vp_sea1d(91)= 9.8829800000000
- SEA1DM_V%vp_sea1d(92)= 9.8636600000000
- SEA1DM_V%vp_sea1d(93)= 9.8443300000000
- SEA1DM_V%vp_sea1d(94)= 9.8250000000000
- SEA1DM_V%vp_sea1d(95)= 9.8056700000000
- SEA1DM_V%vp_sea1d(96)= 9.7863400000000
- SEA1DM_V%vp_sea1d(97)= 9.7670100000000
- SEA1DM_V%vp_sea1d(98)= 9.7476800000000
- SEA1DM_V%vp_sea1d(99)= 9.7283500000000
- SEA1DM_V%vp_sea1d(100)= 9.7090300000000
- SEA1DM_V%vp_sea1d(101)= 9.6897000000000
- SEA1DM_V%vp_sea1d(102)= 9.6703700000000
- SEA1DM_V%vp_sea1d(103)= 9.6510400000000
- SEA1DM_V%vp_sea1d(104)= 9.6317100000000
- SEA1DM_V%vp_sea1d(105)= 9.6123800000000
- SEA1DM_V%vp_sea1d(106)= 9.5930500000000
- SEA1DM_V%vp_sea1d(107)= 9.5737200000000
- SEA1DM_V%vp_sea1d(108)= 9.5543900000000
- SEA1DM_V%vp_sea1d(109)= 9.5350600000000
- SEA1DM_V%vp_sea1d(110)= 9.0766800000000
- SEA1DM_V%vp_sea1d(111)= 9.0188500000000
- SEA1DM_V%vp_sea1d(112)= 8.9610200000000
- SEA1DM_V%vp_sea1d(113)= 8.9031800000000
- SEA1DM_V%vp_sea1d(114)= 8.8453500000000
- SEA1DM_V%vp_sea1d(115)= 8.7875100000000
- SEA1DM_V%vp_sea1d(116)= 8.7296800000000
- SEA1DM_V%vp_sea1d(117)= 8.6718500000000
- SEA1DM_V%vp_sea1d(118)= 8.6140100000000
- SEA1DM_V%vp_sea1d(119)= 8.5561800000000
- SEA1DM_V%vp_sea1d(120)= 8.4983400000000
- SEA1DM_V%vp_sea1d(121)= 8.4405100000000
- SEA1DM_V%vp_sea1d(122)= 8.3826700000000
- SEA1DM_V%vp_sea1d(123)= 8.3248400000000
- SEA1DM_V%vp_sea1d(124)= 8.2670100000000
- SEA1DM_V%vp_sea1d(125)= 8.2091700000000
- SEA1DM_V%vp_sea1d(126)= 8.1513400000000
- SEA1DM_V%vp_sea1d(127)= 8.0935000000000
- SEA1DM_V%vp_sea1d(128)= 8.0356700000000
- SEA1DM_V%vp_sea1d(129)= 7.9778300000000
- SEA1DM_V%vp_sea1d(130)= 7.9200000000000
- SEA1DM_V%vp_sea1d(131)= 7.9200000000000
- SEA1DM_V%vp_sea1d(132)= 7.9200000000000
- SEA1DM_V%vp_sea1d(133)= 7.9200000000000
- SEA1DM_V%vp_sea1d(134)= 7.9200000000000
- SEA1DM_V%vp_sea1d(135)= 7.9200000000000
- SEA1DM_V%vp_sea1d(136)= 7.9200000000000
- SEA1DM_V%vp_sea1d(137)= 7.9200000000000
- SEA1DM_V%vp_sea1d(138)= 7.9200000000000
- SEA1DM_V%vp_sea1d(139)= 7.9200000000000
- SEA1DM_V%vp_sea1d(140)= 7.9200000000000
- SEA1DM_V%vp_sea1d(141)= 7.9200000000000
- SEA1DM_V%vp_sea1d(142)= 7.9200000000000
- SEA1DM_V%vp_sea1d(143)= 7.9200000000000
- SEA1DM_V%vp_sea1d(144)= 7.9200000000000
- SEA1DM_V%vp_sea1d(145)= 7.9200000000000
- SEA1DM_V%vp_sea1d(146)= 7.9200000000000
- SEA1DM_V%vp_sea1d(147)= 7.9200000000000
- SEA1DM_V%vp_sea1d(148)= 7.9200000000000
- SEA1DM_V%vp_sea1d(149)= 7.9200000000000
- SEA1DM_V%vp_sea1d(150)= 7.9200000000000
- SEA1DM_V%vp_sea1d(151)= 7.9200000000000
- SEA1DM_V%vp_sea1d(152)= 6.4000000000000
- SEA1DM_V%vp_sea1d(153)= 6.4000000000000
- SEA1DM_V%vp_sea1d(154)= 6.4000000000000
- SEA1DM_V%vp_sea1d(155)= 6.4000000000000
- SEA1DM_V%vp_sea1d(156)= 6.4000000000000
- SEA1DM_V%vp_sea1d(157)= 6.4000000000000
- SEA1DM_V%vp_sea1d(158)= 6.4000000000000
- SEA1DM_V%vp_sea1d(159)= 6.4000000000000
- SEA1DM_V%vp_sea1d(160)= 6.4000000000000
- SEA1DM_V%vp_sea1d(161)= 6.4000000000000
- SEA1DM_V%vp_sea1d(162)= 6.4000000000000
- SEA1DM_V%vp_sea1d(163)= 6.4000000000000
-
- SEA1DM_V%vs_sea1d(1)= 3.5645400000000
- SEA1DM_V%vs_sea1d(2)= 3.5636500000000
- SEA1DM_V%vs_sea1d(3)= 3.5610200000000
- SEA1DM_V%vs_sea1d(4)= 3.5566300000000
- SEA1DM_V%vs_sea1d(5)= 3.5504900000000
- SEA1DM_V%vs_sea1d(6)= 3.5426100000000
- SEA1DM_V%vs_sea1d(7)= 3.5329700000000
- SEA1DM_V%vs_sea1d(8)= 3.5215900000000
- SEA1DM_V%vs_sea1d(9)= 3.5084500000000
- SEA1DM_V%vs_sea1d(10)= 3.4935700000000
- SEA1DM_V%vs_sea1d(11)= 3.4769300000000
- SEA1DM_V%vs_sea1d(12)= 3.4585500000000
- SEA1DM_V%vs_sea1d(13)= 3.4385400000000
- SEA1DM_V%vs_sea1d(14)= 0.0000000000000
- SEA1DM_V%vs_sea1d(15)= 0.0000000000000
- SEA1DM_V%vs_sea1d(16)= 0.0000000000000
- SEA1DM_V%vs_sea1d(17)= 0.0000000000000
- SEA1DM_V%vs_sea1d(18)= 0.0000000000000
- SEA1DM_V%vs_sea1d(19)= 0.0000000000000
- SEA1DM_V%vs_sea1d(20)= 0.0000000000000
- SEA1DM_V%vs_sea1d(21)= 0.0000000000000
- SEA1DM_V%vs_sea1d(22)= 0.0000000000000
- SEA1DM_V%vs_sea1d(23)= 0.0000000000000
- SEA1DM_V%vs_sea1d(24)= 0.0000000000000
- SEA1DM_V%vs_sea1d(25)= 0.0000000000000
- SEA1DM_V%vs_sea1d(26)= 0.0000000000000
- SEA1DM_V%vs_sea1d(27)= 0.0000000000000
- SEA1DM_V%vs_sea1d(28)= 0.0000000000000
- SEA1DM_V%vs_sea1d(29)= 0.0000000000000
- SEA1DM_V%vs_sea1d(30)= 0.0000000000000
- SEA1DM_V%vs_sea1d(31)= 0.0000000000000
- SEA1DM_V%vs_sea1d(32)= 0.0000000000000
- SEA1DM_V%vs_sea1d(33)= 0.0000000000000
- SEA1DM_V%vs_sea1d(34)= 0.0000000000000
- SEA1DM_V%vs_sea1d(35)= 0.0000000000000
- SEA1DM_V%vs_sea1d(36)= 0.0000000000000
- SEA1DM_V%vs_sea1d(37)= 0.0000000000000
- SEA1DM_V%vs_sea1d(38)= 7.2433800000000
- SEA1DM_V%vs_sea1d(39)= 7.2260300000000
- SEA1DM_V%vs_sea1d(40)= 7.2085500000000
- SEA1DM_V%vs_sea1d(41)= 7.1909200000000
- SEA1DM_V%vs_sea1d(42)= 7.1731300000000
- SEA1DM_V%vs_sea1d(43)= 7.1551600000000
- SEA1DM_V%vs_sea1d(44)= 7.1370000000000
- SEA1DM_V%vs_sea1d(45)= 7.1186000000000
- SEA1DM_V%vs_sea1d(46)= 7.0999800000000
- SEA1DM_V%vs_sea1d(47)= 7.0810900000000
- SEA1DM_V%vs_sea1d(48)= 7.0619300000000
- SEA1DM_V%vs_sea1d(49)= 7.0424700000000
- SEA1DM_V%vs_sea1d(50)= 7.0227000000000
- SEA1DM_V%vs_sea1d(51)= 7.0026000000000
- SEA1DM_V%vs_sea1d(52)= 6.9821500000000
- SEA1DM_V%vs_sea1d(53)= 6.9613400000000
- SEA1DM_V%vs_sea1d(54)= 6.9401300000000
- SEA1DM_V%vs_sea1d(55)= 6.9185200000000
- SEA1DM_V%vs_sea1d(56)= 6.8964900000000
- SEA1DM_V%vs_sea1d(57)= 6.8740200000000
- SEA1DM_V%vs_sea1d(58)= 6.8510900000000
- SEA1DM_V%vs_sea1d(59)= 6.8276700000000
- SEA1DM_V%vs_sea1d(60)= 6.8037600000000
- SEA1DM_V%vs_sea1d(61)= 6.7793300000000
- SEA1DM_V%vs_sea1d(62)= 6.7543700000000
- SEA1DM_V%vs_sea1d(63)= 6.7288500000000
- SEA1DM_V%vs_sea1d(64)= 6.7027700000000
- SEA1DM_V%vs_sea1d(65)= 6.6760900000000
- SEA1DM_V%vs_sea1d(66)= 6.6488100000000
- SEA1DM_V%vs_sea1d(67)= 6.6208900000000
- SEA1DM_V%vs_sea1d(68)= 6.5923300000000
- SEA1DM_V%vs_sea1d(69)= 6.5631100000000
- SEA1DM_V%vs_sea1d(70)= 6.5332000000000
- SEA1DM_V%vs_sea1d(71)= 6.5026000000000
- SEA1DM_V%vs_sea1d(72)= 6.4712600000000
- SEA1DM_V%vs_sea1d(73)= 6.4392000000000
- SEA1DM_V%vs_sea1d(74)= 6.4063800000000
- SEA1DM_V%vs_sea1d(75)= 6.3727800000000
- SEA1DM_V%vs_sea1d(76)= 6.3383900000000
- SEA1DM_V%vs_sea1d(77)= 6.3031900000000
- SEA1DM_V%vs_sea1d(78)= 6.2671500000000
- SEA1DM_V%vs_sea1d(79)= 6.2302600000000
- SEA1DM_V%vs_sea1d(80)= 6.1925100000000
- SEA1DM_V%vs_sea1d(81)= 6.1538700000000
- SEA1DM_V%vs_sea1d(82)= 6.1144200000000
- SEA1DM_V%vs_sea1d(83)= 6.1065800000000
- SEA1DM_V%vs_sea1d(84)= 5.4546300000000
- SEA1DM_V%vs_sea1d(85)= 5.4378400000000
- SEA1DM_V%vs_sea1d(86)= 5.4210500000000
- SEA1DM_V%vs_sea1d(87)= 5.4042500000000
- SEA1DM_V%vs_sea1d(88)= 5.3874600000000
- SEA1DM_V%vs_sea1d(89)= 5.3706700000000
- SEA1DM_V%vs_sea1d(90)= 5.3538800000000
- SEA1DM_V%vs_sea1d(91)= 5.3370900000000
- SEA1DM_V%vs_sea1d(92)= 5.3203000000000
- SEA1DM_V%vs_sea1d(93)= 5.3035100000000
- SEA1DM_V%vs_sea1d(94)= 5.2867200000000
- SEA1DM_V%vs_sea1d(95)= 5.2699300000000
- SEA1DM_V%vs_sea1d(96)= 5.2531400000000
- SEA1DM_V%vs_sea1d(97)= 5.2363500000000
- SEA1DM_V%vs_sea1d(98)= 5.2195600000000
- SEA1DM_V%vs_sea1d(99)= 5.2027700000000
- SEA1DM_V%vs_sea1d(100)= 5.1859800000000
- SEA1DM_V%vs_sea1d(101)= 5.1691900000000
- SEA1DM_V%vs_sea1d(102)= 5.1524000000000
- SEA1DM_V%vs_sea1d(103)= 5.1356100000000
- SEA1DM_V%vs_sea1d(104)= 5.1188200000000
- SEA1DM_V%vs_sea1d(105)= 5.1020200000000
- SEA1DM_V%vs_sea1d(106)= 5.0852300000000
- SEA1DM_V%vs_sea1d(107)= 5.0684400000000
- SEA1DM_V%vs_sea1d(108)= 5.0516500000000
- SEA1DM_V%vs_sea1d(109)= 5.0348600000000
- SEA1DM_V%vs_sea1d(110)= 4.7959100000000
- SEA1DM_V%vs_sea1d(111)= 4.7761200000000
- SEA1DM_V%vs_sea1d(112)= 4.7563200000000
- SEA1DM_V%vs_sea1d(113)= 4.7365300000000
- SEA1DM_V%vs_sea1d(114)= 4.7167300000000
- SEA1DM_V%vs_sea1d(115)= 4.6969400000000
- SEA1DM_V%vs_sea1d(116)= 4.6771400000000
- SEA1DM_V%vs_sea1d(117)= 4.6573400000000
- SEA1DM_V%vs_sea1d(118)= 4.6375500000000
- SEA1DM_V%vs_sea1d(119)= 4.6177500000000
- SEA1DM_V%vs_sea1d(120)= 4.5979600000000
- SEA1DM_V%vs_sea1d(121)= 4.5781600000000
- SEA1DM_V%vs_sea1d(122)= 4.5583700000000
- SEA1DM_V%vs_sea1d(123)= 4.5385700000000
- SEA1DM_V%vs_sea1d(124)= 4.5187700000000
- SEA1DM_V%vs_sea1d(125)= 4.4989800000000
- SEA1DM_V%vs_sea1d(126)= 4.4791800000000
- SEA1DM_V%vs_sea1d(127)= 4.4593900000000
- SEA1DM_V%vs_sea1d(128)= 4.4395900000000
- SEA1DM_V%vs_sea1d(129)= 4.4198000000000
- SEA1DM_V%vs_sea1d(130)= 4.4000000000000
- SEA1DM_V%vs_sea1d(131)= 4.4000000000000
- SEA1DM_V%vs_sea1d(132)= 4.4000000000000
- SEA1DM_V%vs_sea1d(133)= 4.4000000000000
- SEA1DM_V%vs_sea1d(134)= 4.4000000000000
- SEA1DM_V%vs_sea1d(135)= 4.4000000000000
- SEA1DM_V%vs_sea1d(136)= 4.4000000000000
- SEA1DM_V%vs_sea1d(137)= 4.4000000000000
- SEA1DM_V%vs_sea1d(138)= 4.4000000000000
- SEA1DM_V%vs_sea1d(139)= 4.4000000000000
- SEA1DM_V%vs_sea1d(140)= 4.4000000000000
- SEA1DM_V%vs_sea1d(141)= 4.4000000000000
- SEA1DM_V%vs_sea1d(142)= 4.4000000000000
- SEA1DM_V%vs_sea1d(143)= 4.4000000000000
- SEA1DM_V%vs_sea1d(144)= 4.4000000000000
- SEA1DM_V%vs_sea1d(145)= 4.4000000000000
- SEA1DM_V%vs_sea1d(146)= 4.4000000000000
- SEA1DM_V%vs_sea1d(147)= 4.4000000000000
- SEA1DM_V%vs_sea1d(148)= 4.4000000000000
- SEA1DM_V%vs_sea1d(149)= 4.4000000000000
- SEA1DM_V%vs_sea1d(150)= 4.4000000000000
- SEA1DM_V%vs_sea1d(151)= 4.4000000000000
- SEA1DM_V%vs_sea1d(152)= 3.4500000000000
- SEA1DM_V%vs_sea1d(153)= 3.4500000000000
- SEA1DM_V%vs_sea1d(154)= 3.4500000000000
- SEA1DM_V%vs_sea1d(155)= 3.4500000000000
- SEA1DM_V%vs_sea1d(156)= 3.4500000000000
- SEA1DM_V%vs_sea1d(157)= 3.4500000000000
- SEA1DM_V%vs_sea1d(158)= 3.4500000000000
- SEA1DM_V%vs_sea1d(159)= 3.4500000000000
- SEA1DM_V%vs_sea1d(160)= 3.4500000000000
- SEA1DM_V%vs_sea1d(161)= 3.4500000000000
- SEA1DM_V%vs_sea1d(162)= 3.4500000000000
- SEA1DM_V%vs_sea1d(163)= 3.4500000000000
-
- SEA1DM_V%Qkappa_sea1d(1)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(2)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(3)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(4)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(5)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(6)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(7)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(8)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(9)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(10)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(11)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(12)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(13)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(14)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(15)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(16)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(17)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(18)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(19)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(20)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(21)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(22)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(23)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(24)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(25)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(26)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(27)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(28)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(29)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(30)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(31)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(32)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(33)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(34)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(35)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(36)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(37)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(38)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(39)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(40)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(41)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(42)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(43)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(44)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(45)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(46)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(47)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(48)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(49)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(50)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(51)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(52)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(53)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(54)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(55)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(56)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(57)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(58)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(59)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(60)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(61)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(62)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(63)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(64)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(65)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(66)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(67)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(68)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(69)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(70)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(71)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(72)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(73)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(74)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(75)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(76)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(77)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(78)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(79)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(80)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(81)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(82)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(83)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(84)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(85)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(86)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(87)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(88)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(89)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(90)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(91)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(92)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(93)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(94)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(95)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(96)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(97)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(98)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(99)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(100)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(101)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(102)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(103)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(104)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(105)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(106)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(107)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(108)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(109)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(110)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(111)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(112)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(113)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(114)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(115)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(116)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(117)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(118)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(119)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(120)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(121)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(122)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(123)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(124)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(125)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(126)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(127)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(128)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(129)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(130)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(131)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(132)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(133)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(134)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(135)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(136)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(137)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(138)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(139)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(140)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(141)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(142)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(143)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(144)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(145)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(146)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(147)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(148)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(149)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(150)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(151)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(152)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(153)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(154)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(155)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(156)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(157)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(158)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(159)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(160)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(161)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(162)= 99999.0000000000000
- SEA1DM_V%Qkappa_sea1d(163)= 99999.0000000000000
-
- SEA1DM_V%Qmu_sea1d(1)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(2)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(3)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(4)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(5)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(6)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(7)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(8)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(9)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(10)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(11)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(12)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(13)= 84.6000000000000
- SEA1DM_V%Qmu_sea1d(14)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(15)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(16)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(17)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(18)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(19)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(20)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(21)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(22)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(23)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(24)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(25)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(26)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(27)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(28)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(29)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(30)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(31)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(32)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(33)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(34)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(35)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(36)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(37)= 0.0000000000000
- SEA1DM_V%Qmu_sea1d(38)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(39)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(40)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(41)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(42)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(43)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(44)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(45)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(46)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(47)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(48)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(49)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(50)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(51)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(52)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(53)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(54)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(55)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(56)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(57)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(58)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(59)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(60)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(61)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(62)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(63)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(64)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(65)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(66)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(67)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(68)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(69)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(70)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(71)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(72)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(73)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(74)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(75)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(76)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(77)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(78)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(79)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(80)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(81)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(82)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(83)= 312.0000000000000
- SEA1DM_V%Qmu_sea1d(84)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(85)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(86)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(87)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(88)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(89)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(90)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(91)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(92)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(93)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(94)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(95)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(96)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(97)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(98)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(99)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(100)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(101)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(102)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(103)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(104)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(105)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(106)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(107)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(108)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(109)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(110)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(111)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(112)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(113)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(114)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(115)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(116)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(117)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(118)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(119)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(120)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(121)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(122)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(123)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(124)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(125)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(126)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(127)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(128)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(129)= 143.0000000000000
- SEA1DM_V%Qmu_sea1d(130)= 110.0000000000000
- SEA1DM_V%Qmu_sea1d(131)= 80.0000000000000
- SEA1DM_V%Qmu_sea1d(132)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(133)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(134)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(135)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(136)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(137)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(138)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(139)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(140)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(141)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(142)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(143)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(144)= 50.0000000000000
- SEA1DM_V%Qmu_sea1d(145)= 100.0000000000000
- SEA1DM_V%Qmu_sea1d(146)= 150.0000000000000
- SEA1DM_V%Qmu_sea1d(147)= 150.0000000000000
- SEA1DM_V%Qmu_sea1d(148)= 150.0000000000000
- SEA1DM_V%Qmu_sea1d(149)= 150.0000000000000
- SEA1DM_V%Qmu_sea1d(150)= 150.0000000000000
- SEA1DM_V%Qmu_sea1d(151)= 150.0000000000000
- SEA1DM_V%Qmu_sea1d(152)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(153)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(154)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(155)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(156)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(157)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(158)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(159)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(160)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(161)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(162)= 300.0000000000000
- SEA1DM_V%Qmu_sea1d(163)= 300.0000000000000
-
-! strip the crust and replace it by mantle
- if(USE_EXTERNAL_CRUSTAL_MODEL) then
- do i=NR_SEA1D-12,NR_SEA1D
- SEA1DM_V%density_sea1d(i) = SEA1DM_V%density_sea1d(NR_SEA1D-13)
- SEA1DM_V%vp_sea1d(i) = SEA1DM_V%vp_sea1d(NR_SEA1D-13)
- SEA1DM_V%vs_sea1d(i) = SEA1DM_V%vs_sea1d(NR_SEA1D-13)
- SEA1DM_V%Qkappa_sea1d(i) = SEA1DM_V%Qkappa_sea1d(NR_SEA1D-13)
- SEA1DM_V%Qmu_sea1d(i) = SEA1DM_V%Qmu_sea1d(NR_SEA1D-13)
- enddo
- endif
-
- end subroutine define_model_sea1d
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/moho_stretching.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/moho_stretching.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/moho_stretching.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,301 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220)
-
- implicit none
-
- include "constants.h"
-
-! ocean-continent function maximum spherical harmonic degree
- integer, parameter :: NL_OCEAN_CONTINENT = 12
-
-! spherical harmonic coefficients of the ocean-continent function (km)
- double precision A_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT),B_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT)
-
- common /smooth_moho/ A_lm,B_lm
-
- integer myrank
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
- double precision RMOHO,R220
-
- integer ia
-
- integer l,m
- double precision r,theta,phi
- double precision sint,cost,x(2*NL_OCEAN_CONTINENT+1),dx(2*NL_OCEAN_CONTINENT+1)
- double precision elevation
- double precision gamma
-
-! we loop on all the points of the element
- do ia = 1,NGNOD
-
-! convert to r theta phi
- call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
- call reduce(theta,phi)
-
- elevation = 0.0d0
- do l = 0,NL_OCEAN_CONTINENT
- sint = dsin(theta)
- cost = dcos(theta)
- call lgndr(l,cost,sint,x,dx)
- m = 0
- elevation = elevation + A_lm(l,m)*x(m+1)
- do m = 1,l
- elevation = elevation + (A_lm(l,m)*dcos(dble(m)*phi)+B_lm(l,m)*dsin(dble(m)*phi))*x(m+1)
- enddo
- enddo
- elevation = -0.25d0*elevation/R_EARTH_KM
-
- gamma = 0.0d0
- if(r >= RMOHO/R_EARTH) then
-! stretching above the Moho
- gamma = (1.0d0 - r) / (1.0d0 - RMOHO/R_EARTH)
- elseif(r>= R220/R_EARTH .and. r< RMOHO/R_EARTH) then
-! stretching between R220 and RMOHO
- gamma = (r - R220/R_EARTH) / (RMOHO/R_EARTH - R220/R_EARTH)
- endif
- if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for Moho topography')
-
- xelm(ia) = xelm(ia)*(ONE + gamma * elevation / r)
- yelm(ia) = yelm(ia)*(ONE + gamma * elevation / r)
- zelm(ia) = zelm(ia)*(ONE + gamma * elevation / r)
-
- enddo
-
- end subroutine moho_stretching
-
- subroutine read_smooth_moho
-
- implicit none
-
-! ocean-continent function maximum spherical harmonic degree
- integer, parameter :: NL_OCEAN_CONTINENT = 12
-
-! spherical harmonic coefficients of the ocean-continent function (km)
- double precision A_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT),B_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT)
-
- common /smooth_moho/ A_lm,B_lm
-
-! integer l,m
-!
-! ocean-continent function (km)
-! open(unit=10,file='DATA/ocean_continent_function/ocean_continent_function.txt',status='old',action='read')
-! do l=0,NL_OCEAN_CONTINENT
-! read(10,*) A_lm(l,0),(A_lm(l,m),B_lm(l,m),m=1,l)
-! enddo
-! close(10)
-
- A_lm(0,0) = -3.8201999E-04
- B_lm(0,0) = 0.
- A_lm(1,0) = 13.88800
- B_lm(1,0) = 0.
- A_lm(1,1) = -15.24000
- B_lm(1,1) = -9.187200
- A_lm(2,0) = 11.21500
- B_lm(2,0) = 0.
- A_lm(2,1) = -6.754500
- B_lm(2,1) = -8.516700
- A_lm(2,2) = -8.327800
- B_lm(2,2) = -5.029200
- A_lm(3,0) = -3.614500
- B_lm(3,0) = 0.
- A_lm(3,1) = 5.394800
- B_lm(3,1) = -0.9220800
- A_lm(3,2) = -10.05100
- B_lm(3,2) = 13.98100
- A_lm(3,3) = -2.711200
- B_lm(3,3) = -13.57100
- A_lm(4,0) = 7.523300
- B_lm(4,0) = 0.
- A_lm(4,1) = 5.156100
- B_lm(4,1) = 2.184400
- A_lm(4,2) = -10.67300
- B_lm(4,2) = 2.640600
- A_lm(4,3) = -7.786300
- B_lm(4,3) = 0.3674500
- A_lm(4,4) = -3.076400
- B_lm(4,4) = 16.83000
- A_lm(5,0) = -9.681000
- B_lm(5,0) = 0.
- A_lm(5,1) = 0.5026800
- B_lm(5,1) = 2.111300
- A_lm(5,2) = -2.931000
- B_lm(5,2) = -4.329000
- A_lm(5,3) = -1.766800
- B_lm(5,3) = -3.621200
- A_lm(5,4) = 16.08200
- B_lm(5,4) = -4.493900
- A_lm(5,5) = -0.3705800
- B_lm(5,5) = -5.574500
- A_lm(6,0) = 4.407900
- B_lm(6,0) = 0.
- A_lm(6,1) = 0.3799000
- B_lm(6,1) = 1.589400
- A_lm(6,2) = -1.886400
- B_lm(6,2) = -0.5686300
- A_lm(6,3) = -0.9816800
- B_lm(6,3) = -5.827800
- A_lm(6,4) = 3.620600
- B_lm(6,4) = -2.713100
- A_lm(6,5) = 1.445600
- B_lm(6,5) = 3.964100
- A_lm(6,6) = 1.167400
- B_lm(6,6) = 2.134100
- A_lm(7,0) = -4.086100
- B_lm(7,0) = 0.
- A_lm(7,1) = 0.5462000
- B_lm(7,1) = -4.488100
- A_lm(7,2) = 3.116400
- B_lm(7,2) = 1.793600
- A_lm(7,3) = 2.594600
- B_lm(7,3) = -2.129100
- A_lm(7,4) = -5.445000
- B_lm(7,4) = 0.5381500
- A_lm(7,5) = -2.178100
- B_lm(7,5) = 1.766700
- A_lm(7,6) = -1.040000
- B_lm(7,6) = -5.541000
- A_lm(7,7) = 1.536500
- B_lm(7,7) = 3.700600
- A_lm(8,0) = -2.562200
- B_lm(8,0) = 0.
- A_lm(8,1) = 0.3736200
- B_lm(8,1) = 1.488000
- A_lm(8,2) = 1.347500
- B_lm(8,2) = 0.5288200
- A_lm(8,3) = -0.8493700
- B_lm(8,3) = -1.626500
- A_lm(8,4) = 0.2423400
- B_lm(8,4) = 4.202800
- A_lm(8,5) = 2.052200
- B_lm(8,5) = 0.6880400
- A_lm(8,6) = 2.838500
- B_lm(8,6) = 2.835700
- A_lm(8,7) = -4.981400
- B_lm(8,7) = -1.883100
- A_lm(8,8) = -1.102800
- B_lm(8,8) = -1.951700
- A_lm(9,0) = -1.202100
- B_lm(9,0) = 0.
- A_lm(9,1) = 1.020300
- B_lm(9,1) = 1.371000
- A_lm(9,2) = -0.3430100
- B_lm(9,2) = 0.8782800
- A_lm(9,3) = -0.4462500
- B_lm(9,3) = -0.3046100
- A_lm(9,4) = 0.7750700
- B_lm(9,4) = 2.351600
- A_lm(9,5) = -2.092600
- B_lm(9,5) = -2.377100
- A_lm(9,6) = 0.3126900
- B_lm(9,6) = 4.996000
- A_lm(9,7) = -2.284000
- B_lm(9,7) = 1.183700
- A_lm(9,8) = 1.445900
- B_lm(9,8) = 1.080000
- A_lm(9,9) = 1.146700
- B_lm(9,9) = 1.457800
- A_lm(10,0) = -2.516900
- B_lm(10,0) = 0.
- A_lm(10,1) = -0.9739500
- B_lm(10,1) = -0.7195500
- A_lm(10,2) = -2.846000
- B_lm(10,2) = -1.464700
- A_lm(10,3) = 2.720100
- B_lm(10,3) = 0.8241400
- A_lm(10,4) = -1.247800
- B_lm(10,4) = 1.220300
- A_lm(10,5) = -1.638500
- B_lm(10,5) = -1.099500
- A_lm(10,6) = 3.043000
- B_lm(10,6) = -1.976400
- A_lm(10,7) = -1.007300
- B_lm(10,7) = -1.604900
- A_lm(10,8) = 0.6620500
- B_lm(10,8) = -1.135000
- A_lm(10,9) = -3.576800
- B_lm(10,9) = 0.5554900
- A_lm(10,10) = 2.418700
- B_lm(10,10) = -1.482200
- A_lm(11,0) = 0.7158800
- B_lm(11,0) = 0.
- A_lm(11,1) = -3.694800
- B_lm(11,1) = 0.8491400
- A_lm(11,2) = 9.3208998E-02
- B_lm(11,2) = -1.276000
- A_lm(11,3) = 1.575600
- B_lm(11,3) = 0.1972100
- A_lm(11,4) = 0.8989600
- B_lm(11,4) = -1.063000
- A_lm(11,5) = -0.6301000
- B_lm(11,5) = -1.329400
- A_lm(11,6) = 1.389000
- B_lm(11,6) = 1.184100
- A_lm(11,7) = 0.5640700
- B_lm(11,7) = 2.286200
- A_lm(11,8) = 1.530300
- B_lm(11,8) = 0.7677500
- A_lm(11,9) = 0.8495500
- B_lm(11,9) = 0.7247500
- A_lm(11,10) = 2.106800
- B_lm(11,10) = 0.6588000
- A_lm(11,11) = 0.6067800
- B_lm(11,11) = 0.1366800
- A_lm(12,0) = -2.598700
- B_lm(12,0) = 0.
- A_lm(12,1) = -1.150500
- B_lm(12,1) = -0.8425700
- A_lm(12,2) = -0.1593300
- B_lm(12,2) = -1.241400
- A_lm(12,3) = 1.508600
- B_lm(12,3) = 0.3385500
- A_lm(12,4) = -1.941200
- B_lm(12,4) = 1.120000
- A_lm(12,5) = -0.4630500
- B_lm(12,5) = -6.4753003E-02
- A_lm(12,6) = 0.8967000
- B_lm(12,6) = 4.7417998E-02
- A_lm(12,7) = 4.5407999E-02
- B_lm(12,7) = 0.8876400
- A_lm(12,8) = -2.444400
- B_lm(12,8) = 1.172500
- A_lm(12,9) = -2.593400
- B_lm(12,9) = 0.1703700
- A_lm(12,10) = 0.5662700
- B_lm(12,10) = 0.7050800
- A_lm(12,11) = -0.1930000
- B_lm(12,11) = -2.008100
- A_lm(12,12) = -3.187900
- B_lm(12,12) = -1.672000
-
- end subroutine read_smooth_moho
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mpif.h
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mpif.h 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mpif.h 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,265 +0,0 @@
-! mpif.h. Generated from /opt/mpich/myrinet/intel//include/mpif.h by configure.
-
-!
-!
-! (C) 1993 by Argonne National Laboratory and Mississipi State University.
-! All rights reserved. See COPYRIGHT in top-level directory.
-!
-!
-! user include file for MPI programs, with no dependencies
-!
-! It really is not possible to make a perfect include file that can
-! be used by both F77 and F90 compilers, but this is close. We have removed
-! continuation lines (allows free form input in F90); systems whose
-! Fortran compilers support ! instead of just C or * for comments can
-! globally replace a C in the first column with !; the resulting file
-! should work for both Fortran 77 and Fortran 90.
-!
-! If your Fortran compiler supports ! for comments, you can run this
-! through sed with
-! sed -e 's/^C/\!/g'
-!
-! We have also removed the use of contractions (involving the single quote)
-! character because some users use .F instead of .f files (to invoke the
-! cpp preprocessor) and further, their preprocessor is determined to find
-! matching single quote pairs (and probably double quotes; given the
-! different rules in C and Fortran, this sounds like a disaster). Rather than
-! take the position that the poor users should get a better system, we
-! have removed the text that caused problems. Of course, the users SHOULD
-! get a better system...
-!
-! return codes
- INTEGER MPI_SUCCESS,MPI_ERR_BUFFER,MPI_ERR_COUNT,MPI_ERR_TYPE
- INTEGER MPI_ERR_TAG,MPI_ERR_COMM,MPI_ERR_RANK,MPI_ERR_ROOT
- INTEGER MPI_ERR_GROUP
- INTEGER MPI_ERR_OP,MPI_ERR_TOPOLOGY,MPI_ERR_DIMS,MPI_ERR_ARG
- INTEGER MPI_ERR_UNKNOWN,MPI_ERR_TRUNCATE,MPI_ERR_OTHER
- INTEGER MPI_ERR_INTERN,MPI_ERR_IN_STATUS,MPI_ERR_PENDING
- INTEGER MPI_ERR_REQUEST, MPI_ERR_LASTCODE
- PARAMETER (MPI_SUCCESS=0,MPI_ERR_BUFFER=1,MPI_ERR_COUNT=2)
- PARAMETER (MPI_ERR_TYPE=3,MPI_ERR_TAG=4,MPI_ERR_COMM=5)
- PARAMETER (MPI_ERR_RANK=6,MPI_ERR_ROOT=7,MPI_ERR_GROUP=8)
- PARAMETER (MPI_ERR_OP=9,MPI_ERR_TOPOLOGY=10,MPI_ERR_DIMS=11)
- PARAMETER (MPI_ERR_ARG=12,MPI_ERR_UNKNOWN=13)
- PARAMETER (MPI_ERR_TRUNCATE=14,MPI_ERR_OTHER=15)
- PARAMETER (MPI_ERR_INTERN=16,MPI_ERR_IN_STATUS=17)
- PARAMETER (MPI_ERR_PENDING=18,MPI_ERR_REQUEST=19)
- PARAMETER (MPI_ERR_LASTCODE=1073741823)
-!
- INTEGER MPI_UNDEFINED
- parameter (MPI_UNDEFINED = (-32766))
-!
- INTEGER MPI_GRAPH, MPI_CART
- PARAMETER (MPI_GRAPH = 1, MPI_CART = 2)
- INTEGER MPI_PROC_NULL
- PARAMETER ( MPI_PROC_NULL = (-1) )
-!
- INTEGER MPI_BSEND_OVERHEAD
- PARAMETER ( MPI_BSEND_OVERHEAD = 512 )
-
- INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR
- PARAMETER(MPI_SOURCE=2, MPI_TAG=3, MPI_ERROR=4)
- INTEGER MPI_STATUS_SIZE
- PARAMETER (MPI_STATUS_SIZE=4)
- INTEGER MPI_MAX_PROCESSOR_NAME, MPI_MAX_ERROR_STRING
- PARAMETER (MPI_MAX_PROCESSOR_NAME=256)
- PARAMETER (MPI_MAX_ERROR_STRING=512)
- INTEGER MPI_MAX_NAME_STRING
- PARAMETER (MPI_MAX_NAME_STRING=63)
- INTEGER MPI_MAX_PORT_NAME
- PARAMETER (MPI_MAX_PORT_NAME=256)
-!
- INTEGER MPI_COMM_NULL
- PARAMETER (MPI_COMM_NULL=0)
-!
- INTEGER MPI_DATATYPE_NULL
- PARAMETER (MPI_DATATYPE_NULL = 0)
-
- INTEGER MPI_ERRHANDLER_NULL
- PARAMETER (MPI_ERRHANDLER_NULL = 0)
-
- INTEGER MPI_GROUP_NULL
- PARAMETER (MPI_GROUP_NULL = 0)
-
- INTEGER MPI_KEYVAL_INVALID
- PARAMETER (MPI_KEYVAL_INVALID = 0)
-
- INTEGER MPI_REQUEST_NULL
- PARAMETER (MPI_REQUEST_NULL = 0)
-!
- INTEGER MPI_IDENT, MPI_CONGRUENT, MPI_SIMILAR, MPI_UNEQUAL
- PARAMETER (MPI_IDENT=0, MPI_CONGRUENT=1, MPI_SIMILAR=2)
- PARAMETER (MPI_UNEQUAL=3)
-!
-! MPI_BOTTOM needs to be a known address; here we put it at the
-! beginning of the common block. The point-to-point and collective
-! routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not.
-!
-! MPI_STATUS_IGNORE and MPI_STATUSES_IGNORE are similar objects
-! Until the underlying MPI library implements the C version of these
-! (a null pointer), these are declared as arrays of MPI_STATUS_SIZE
-!
-! The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL.
-! Their values are zero if they are not available. Note that
-! using these reduces the portability of code (though may enhance
-! portability between Crays and other systems)
-!
- INTEGER MPI_TAG_UB, MPI_HOST, MPI_IO
- INTEGER MPI_BOTTOM
- INTEGER MPI_STATUS_IGNORE(MPI_STATUS_SIZE)
- INTEGER MPI_STATUSES_IGNORE(MPI_STATUS_SIZE)
- INTEGER MPI_INTEGER, MPI_REAL, MPI_DOUBLE_PRECISION
- INTEGER MPI_COMPLEX, MPI_DOUBLE_COMPLEX,MPI_LOGICAL
- INTEGER MPI_CHARACTER, MPI_BYTE, MPI_2INTEGER, MPI_2REAL
- INTEGER MPI_2DOUBLE_PRECISION, MPI_2COMPLEX, MPI_2DOUBLE_COMPLEX
- INTEGER MPI_UB, MPI_LB
- INTEGER MPI_PACKED, MPI_WTIME_IS_GLOBAL
- INTEGER MPI_COMM_WORLD, MPI_COMM_SELF, MPI_GROUP_EMPTY
- INTEGER MPI_SUM, MPI_MAX, MPI_MIN, MPI_PROD, MPI_LAND, MPI_BAND
- INTEGER MPI_LOR, MPI_BOR, MPI_LXOR, MPI_BXOR, MPI_MINLOC
- INTEGER MPI_MAXLOC
- INTEGER MPI_OP_NULL
- INTEGER MPI_ERRORS_ARE_FATAL, MPI_ERRORS_RETURN
-!
- PARAMETER (MPI_ERRORS_ARE_FATAL=119)
- PARAMETER (MPI_ERRORS_RETURN=120)
-!
- PARAMETER (MPI_COMPLEX=23,MPI_DOUBLE_COMPLEX=24,MPI_LOGICAL=25)
- PARAMETER (MPI_REAL=26,MPI_DOUBLE_PRECISION=27,MPI_INTEGER=28)
- PARAMETER (MPI_2INTEGER=29,MPI_2COMPLEX=30,MPI_2DOUBLE_COMPLEX=31)
- PARAMETER (MPI_2REAL=32,MPI_2DOUBLE_PRECISION=33,MPI_CHARACTER=1)
- PARAMETER (MPI_BYTE=3,MPI_UB=16,MPI_LB=15,MPI_PACKED=14)
-
- INTEGER MPI_ORDER_C, MPI_ORDER_FORTRAN
- PARAMETER (MPI_ORDER_C=56, MPI_ORDER_FORTRAN=57)
- INTEGER MPI_DISTRIBUTE_BLOCK, MPI_DISTRIBUTE_CYCLIC
- INTEGER MPI_DISTRIBUTE_NONE, MPI_DISTRIBUTE_DFLT_DARG
- PARAMETER (MPI_DISTRIBUTE_BLOCK=121, MPI_DISTRIBUTE_CYCLIC=122)
- PARAMETER (MPI_DISTRIBUTE_NONE=123)
- PARAMETER (MPI_DISTRIBUTE_DFLT_DARG=-49767)
- INTEGER MPI_MAX_INFO_KEY, MPI_MAX_INFO_VAL
- PARAMETER (MPI_MAX_INFO_KEY=255, MPI_MAX_INFO_VAL=1024)
- INTEGER MPI_INFO_NULL
- PARAMETER (MPI_INFO_NULL=0)
-
-!
-! Optional Fortran Types. Configure attempts to determine these.
-!
- INTEGER MPI_INTEGER1, MPI_INTEGER2, MPI_INTEGER4, MPI_INTEGER8
- INTEGER MPI_INTEGER16
- INTEGER MPI_REAL4, MPI_REAL8, MPI_REAL16
- INTEGER MPI_COMPLEX8, MPI_COMPLEX16, MPI_COMPLEX32
- PARAMETER (MPI_INTEGER1=1,MPI_INTEGER2=4)
- PARAMETER (MPI_INTEGER4=6)
- PARAMETER (MPI_INTEGER8=8)
- PARAMETER (MPI_INTEGER16=0)
- PARAMETER (MPI_REAL4=10)
- PARAMETER (MPI_REAL8=11)
- PARAMETER (MPI_REAL16=12)
- PARAMETER (MPI_COMPLEX8=23)
- PARAMETER (MPI_COMPLEX16=24)
- PARAMETER (MPI_COMPLEX32=0)
-!
-! This is now handled with either the "pointer" extension or this same
-! code, appended at the end.
-! COMMON /MPIPRIV/ MPI_BOTTOM,MPI_STATUS_IGNORE,MPI_STATUSES_IGNORE
-!C
-!C Without this save, some Fortran implementations may make the common
-!C dynamic!
-!C
-!C For a Fortran90 module, we might replace /MPIPRIV/ with a simple
-!C SAVE MPI_BOTTOM
-!C
-! SAVE /MPIPRIV/
-!
- PARAMETER (MPI_MAX=100,MPI_MIN=101,MPI_SUM=102,MPI_PROD=103)
- PARAMETER (MPI_LAND=104,MPI_BAND=105,MPI_LOR=106,MPI_BOR=107)
- PARAMETER (MPI_LXOR=108,MPI_BXOR=109,MPI_MINLOC=110)
- PARAMETER (MPI_MAXLOC=111, MPI_OP_NULL=0)
-!
- PARAMETER (MPI_GROUP_EMPTY=90,MPI_COMM_WORLD=91,MPI_COMM_SELF=92)
- PARAMETER (MPI_TAG_UB=80,MPI_HOST=82,MPI_IO=84)
- PARAMETER (MPI_WTIME_IS_GLOBAL=86)
-!
- INTEGER MPI_ANY_SOURCE
- PARAMETER (MPI_ANY_SOURCE = (-2))
- INTEGER MPI_ANY_TAG
- PARAMETER (MPI_ANY_TAG = (-1))
-!
- INTEGER MPI_VERSION, MPI_SUBVERSION
- PARAMETER (MPI_VERSION = 1, MPI_SUBVERSION = 2)
-!
-! There are additional MPI-2 constants
- INTEGER MPI_ADDRESS_KIND, MPI_OFFSET_KIND
- PARAMETER (MPI_ADDRESS_KIND=8)
- PARAMETER (MPI_OFFSET_KIND=8)
-!
-! All other MPI routines are subroutines
-! This may cause some Fortran compilers to complain about defined and
-! not used. Such compilers should be improved.
-!
-! Some Fortran compilers will not link programs that contain
-! external statements to routines that are not provided, even if
-! the routine is never called. Remove PMPI_WTIME and PMPI_WTICK
-! if you have trouble with them.
-!
- DOUBLE PRECISION MPI_WTIME, MPI_WTICK,PMPI_WTIME,PMPI_WTICK
- EXTERNAL MPI_WTIME, MPI_WTICK,PMPI_WTIME,PMPI_WTICK
-!
-! The attribute copy/delete subroutines are symbols that can be passed
-! to MPI routines
-!
- EXTERNAL MPI_NULL_COPY_FN, MPI_NULL_DELETE_FN, MPI_DUP_FN
- COMMON /MPIPRIV/ MPI_BOTTOM,MPI_STATUS_IGNORE,MPI_STATUSES_IGNORE
-!
-! Without this save, some Fortran implementations may make the common
-! dynamic!
-!
-! For a Fortran90 module, we might replace /MPIPRIV/ with a simple
-! SAVE MPI_BOTTOM
-!
- SAVE /MPIPRIV/
-!
-! $Id: mpiof.h.in,v 1.3 1999/08/06 18:33:09 thakur Exp $
-!
-! Copyright (C) 1997 University of Chicago.
-! See COPYRIGHT notice in top-level directory.
-!
-!
-! user include file for Fortran MPI-IO programs
-!
- INTEGER MPI_MODE_RDONLY, MPI_MODE_RDWR, MPI_MODE_WRONLY
- INTEGER MPI_MODE_DELETE_ON_CLOSE, MPI_MODE_UNIQUE_OPEN
- INTEGER MPI_MODE_CREATE, MPI_MODE_EXCL
- INTEGER MPI_MODE_APPEND, MPI_MODE_SEQUENTIAL
- PARAMETER (MPI_MODE_RDONLY=2, MPI_MODE_RDWR=8, MPI_MODE_WRONLY=4)
- PARAMETER (MPI_MODE_CREATE=1, MPI_MODE_DELETE_ON_CLOSE=16)
- PARAMETER (MPI_MODE_UNIQUE_OPEN=32, MPI_MODE_EXCL=64)
- PARAMETER (MPI_MODE_APPEND=128, MPI_MODE_SEQUENTIAL=256)
-!
- INTEGER MPI_FILE_NULL
- PARAMETER (MPI_FILE_NULL=0)
-!
- INTEGER MPI_MAX_DATAREP_STRING
- PARAMETER (MPI_MAX_DATAREP_STRING=128)
-!
- INTEGER MPI_SEEK_SET, MPI_SEEK_CUR, MPI_SEEK_END
- PARAMETER (MPI_SEEK_SET=600, MPI_SEEK_CUR=602, MPI_SEEK_END=604)
-!
- INTEGER MPIO_REQUEST_NULL
- PARAMETER (MPIO_REQUEST_NULL=0)
-!
-!
-!
-
-
-
-
-
-
-
-!
-!
-!
-!
-!
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/netlib_specfun_erf.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/netlib_specfun_erf.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/netlib_specfun_erf.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,318 +0,0 @@
-
- subroutine calerf(ARG,RESULT,JINT)
-
-!------------------------------------------------------------------
-!
-! This routine can be freely obtained from Netlib
-! at http://www.netlib.org/specfun/erf
-!
-! Most Netlib software packages have no restrictions on their use
-! but Netlib recommends that you check with the authors to be sure.
-! See http://www.netlib.org/misc/faq.html#2.3 for details.
-!
-!------------------------------------------------------------------
-!
-! This packet evaluates erf(x) for a real argument x.
-! It contains one FUNCTION type subprogram: ERF,
-! and one SUBROUTINE type subprogram, CALERF. The calling
-! statements for the primary entries are:
-!
-! Y = ERF(X)
-!
-! The routine CALERF is intended for internal packet use only,
-! all computations within the packet being concentrated in this
-! routine. The function subprograms invoke CALERF with the
-! statement
-!
-! call CALERF(ARG,RESULT,JINT)
-!
-! where the parameter usage is as follows
-!
-! Function Parameters for CALERF
-! call ARG Result JINT
-!
-! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0
-!
-! The main computation evaluates near-minimax approximations
-! from "Rational Chebyshev approximations for the error function"
-! by William J. Cody, Math. Comp., 1969, PP. 631-638. This
-! transportable program uses rational functions that theoretically
-! approximate erf(x) and erfc(x) to at least 18 significant
-! decimal digits. The accuracy achieved depends on the arithmetic
-! system, the compiler, the intrinsic functions, and proper
-! selection of the machine-dependent constants.
-!
-!*******************************************************************
-!*******************************************************************
-!
-! Explanation of machine-dependent constants
-!
-! XMIN = the smallest positive floating-point number.
-! XINF = the largest positive finite floating-point number.
-! XNEG = the largest negative argument acceptable to ERFCX;
-! the negative of the solution to the equation
-! 2*exp(x*x) = XINF.
-! XSMALL = argument below which erf(x) may be represented by
-! 2*x/sqrt(pi) and above which x*x will not underflow.
-! A conservative value is the largest machine number X
-! such that 1.0 + X = 1.0 to machine precision.
-! XBIG = largest argument acceptable to ERFC; solution to
-! the equation: W(x) * (1-0.5/x**2) = XMIN, where
-! W(x) = exp(-x*x)/[x*sqrt(pi)].
-! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to
-! machine precision. A conservative value is
-! 1/[2*sqrt(XSMALL)]
-! XMAX = largest acceptable argument to ERFCX; the minimum
-! of XINF and 1/[sqrt(pi)*XMIN].
-!
-! Approximate IEEE double precision values are defined below.
-!
-!*******************************************************************
-!*******************************************************************
-!
-! Error returns
-!
-! The program returns ERFC = 0 for ARG >= XBIG;
-!
-! Author: William J. Cody
-! Mathematics and Computer Science Division
-! Argonne National Laboratory
-! Argonne, IL 60439, USA
-!
-! Latest modification: March 19, 1990
-!
-! Converted to Fortran90 and slightly modified by
-! Dimitri Komatitsch, University of Pau, France, November 2007.
-!
-!------------------------------------------------------------------
-
- implicit none
-
- integer I,JINT
- double precision A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEEN,SQRPI, &
- TWO,THRESHOLD,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL, &
- Y,YSQ,ZERO
- dimension A(5),B(4),C(9),D(8),P(6),Q(5)
-
-!------------------------------------------------------------------
-! Mathematical constants
-!------------------------------------------------------------------
- data FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/, &
- SQRPI/5.6418958354775628695D-1/,THRESHOLD/0.46875D0/, &
- SIXTEEN/16.0D0/
-
-!------------------------------------------------------------------
-! Machine-dependent constants
-!------------------------------------------------------------------
- data XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/, &
- XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/
-
-!------------------------------------------------------------------
-! Coefficients for approximation to erf in first interval
-!------------------------------------------------------------------
- data A/3.16112374387056560D00,1.13864154151050156D02, &
- 3.77485237685302021D02,3.20937758913846947D03, &
- 1.85777706184603153D-1/
- data B/2.36012909523441209D01,2.44024637934444173D02, &
- 1.28261652607737228D03,2.84423683343917062D03/
-
-!------------------------------------------------------------------
-! Coefficients for approximation to erfc in second interval
-!------------------------------------------------------------------
- data C/5.64188496988670089D-1,8.88314979438837594D0, &
- 6.61191906371416295D01,2.98635138197400131D02, &
- 8.81952221241769090D02,1.71204761263407058D03, &
- 2.05107837782607147D03,1.23033935479799725D03, &
- 2.15311535474403846D-8/
- data D/1.57449261107098347D01,1.17693950891312499D02, &
- 5.37181101862009858D02,1.62138957456669019D03, &
- 3.29079923573345963D03,4.36261909014324716D03, &
- 3.43936767414372164D03,1.23033935480374942D03/
-
-!------------------------------------------------------------------
-! Coefficients for approximation to erfc in third interval
-!------------------------------------------------------------------
- data P/3.05326634961232344D-1,3.60344899949804439D-1, &
- 1.25781726111229246D-1,1.60837851487422766D-2, &
- 6.58749161529837803D-4,1.63153871373020978D-2/
- data Q/2.56852019228982242D00,1.87295284992346047D00, &
- 5.27905102951428412D-1,6.05183413124413191D-2, &
- 2.33520497626869185D-3/
-
- X = ARG
- Y = ABS(X)
- if (Y <= THRESHOLD) then
-
-!------------------------------------------------------------------
-! Evaluate erf for |X| <= 0.46875
-!------------------------------------------------------------------
- YSQ = ZERO
- if (Y > XSMALL) YSQ = Y * Y
- XNUM = A(5)*YSQ
- XDEN = YSQ
-
- do I = 1, 3
- XNUM = (XNUM + A(I)) * YSQ
- XDEN = (XDEN + B(I)) * YSQ
- enddo
-
- RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
- if (JINT /= 0) RESULT = ONE - RESULT
- if (JINT == 2) RESULT = EXP(YSQ) * RESULT
- goto 800
-
-!------------------------------------------------------------------
-! Evaluate erfc for 0.46875 <= |X| <= 4.0
-!------------------------------------------------------------------
- else if (Y <= FOUR) then
- XNUM = C(9)*Y
- XDEN = Y
-
- do I = 1, 7
- XNUM = (XNUM + C(I)) * Y
- XDEN = (XDEN + D(I)) * Y
- enddo
-
- RESULT = (XNUM + C(8)) / (XDEN + D(8))
- if (JINT /= 2) then
- YSQ = AINT(Y*SIXTEEN)/SIXTEEN
- DEL = (Y-YSQ)*(Y+YSQ)
- RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
- endif
-
-!------------------------------------------------------------------
-! Evaluate erfc for |X| > 4.0
-!------------------------------------------------------------------
- else
- RESULT = ZERO
- if (Y >= XBIG) then
- if (JINT /= 2 .OR. Y >= XMAX) goto 300
- if (Y >= XHUGE) then
- RESULT = SQRPI / Y
- goto 300
- endif
- endif
- YSQ = ONE / (Y * Y)
- XNUM = P(6)*YSQ
- XDEN = YSQ
-
- do I = 1, 4
- XNUM = (XNUM + P(I)) * YSQ
- XDEN = (XDEN + Q(I)) * YSQ
- enddo
-
- RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
- RESULT = (SQRPI - RESULT) / Y
- if (JINT /= 2) then
- YSQ = AINT(Y*SIXTEEN)/SIXTEEN
- DEL = (Y-YSQ)*(Y+YSQ)
- RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
- endif
- endif
-
-!------------------------------------------------------------------
-! Fix up for negative argument, erf, etc.
-!------------------------------------------------------------------
- 300 if (JINT == 0) then
- RESULT = (HALF - RESULT) + HALF
- if (X < ZERO) RESULT = -RESULT
- else if (JINT == 1) then
- if (X < ZERO) RESULT = TWO - RESULT
- else
- if (X < ZERO) then
- if (X < XNEG) then
- RESULT = XINF
- else
- YSQ = AINT(X*SIXTEEN)/SIXTEEN
- DEL = (X-YSQ)*(X+YSQ)
- Y = EXP(YSQ*YSQ) * EXP(DEL)
- RESULT = (Y+Y) - RESULT
- endif
- endif
- endif
-
- 800 return
-
- end subroutine calerf
-
-!--------------------------------------------------------------------
-
- double precision function netlib_specfun_erf(X)
-
-! This subprogram computes approximate values for erf(x).
-! (see comments heading CALERF).
-!
-! Author/date: William J. Cody, January 8, 1985
-
- implicit none
-
- integer JINT
- double precision X, RESULT
-
- JINT = 0
- call calerf(X,RESULT,JINT)
- netlib_specfun_erf = RESULT
-
- end function netlib_specfun_erf
-
-!
-! Subject: RE: Can one freely use and redistribute Fortran routines "specfun" from Netlib?
-! From: Jack Dongarra
-! Date: Wed, 21 Nov 2007 10:33:45 -0500
-! To: Rusty Lusk, Dimitri Komatitsch
-!
-! Yes the code can freely be used and incorporated into other software. You
-! should of course acknowledge the use of the software.
-!
-! Hope this helps,
-!
-! Jack Dongarra
-!
-! **********************************************************************
-! Prof. Jack Dongarra; Innovative Computing Laboratory; EECS Department;
-! 1122 Volunteer Blvd; University of Tennessee; Knoxville TN 37996-3450;
-! +1-865-974-8295; http://www.cs.utk.edu/~dongarra/
-!
-! -----Original Message-----
-! From: Rusty Lusk
-! Sent: Wednesday, November 21, 2007 10:29 AM
-! To: Dimitri Komatitsch
-! Cc: Jack Dongarra
-! Subject: Re: Can one freely use and redistribute Fortran routines "specfun"
-! from Netlib?
-!
-! Netlib is managed at the University of Tennesee, not Argonne at this
-! point. I have copied Jack Dongarra on this reply; he should be able
-! to answer questions about licensing issues for code from Netlib.
-!
-! Regards,
-! Rusty
-!
-! On Nov 21, 2007, at 8:36 AM, Dimitri Komatitsch wrote:
-!
-! >
-! > Dear Sir,
-! >
-! > Can one freely use and redistribute Fortran routines "specfun" from
-! > Netlib http://netlib2.cs.utk.edu/specfun/
-! > which were written back in 1985-1990 by William J. Cody
-! > from the Mathematics and Computer Science Division at Argonne?
-! >
-! > We use one of these routines (the error function, erf())
-! > in one of our source codes, which we would like to
-! > release as open source under GPL v2+, and we therefore
-! > wonder if we could include that erf() routine in the
-! > package in a separate file (of course saying in a comment in the
-! > header that it comes from Netlib and was written by William J. Cody from
-! > Argonne).
-! >
-! > Thank you,
-! > Best regards,
-! >
-! > Dimitri Komatitsch.
-! >
-! > --
-! > Dimitri Komatitsch - dimitri.komatitsch aT univ-pau.fr
-! > Professor, University of Pau, Institut universitaire de France
-! > and INRIA Magique3D, France http://www.univ-pau.fr/~dkomati1
-! >
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/precision.h
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/precision.h 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/precision.h 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,38 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! precision.h. Generated from precision.h.in by configure.
-
-!
-! solver in single or double precision depending on the machine
-!
-! set to MPI_REAL to run in single precision
-! set to MPI_DOUBLE_PRECISION to run in double precision
-!
-! ALSO CHANGE FILE constants.h ACCORDINGLY
-!
- integer, parameter :: CUSTOM_MPI_TYPE = MPI_REAL
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_compute_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_compute_parameters.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_compute_parameters.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,2506 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,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
-
- 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,LOCAL_PATH,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_region_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'
-
- 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
-
-! 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)
-
-!! DK DK suppressed because this routine should not write anything to the screen
-! write(*,*)'##############################################################'
-! write(*,*)
-! write(*,*)' Auto Radial Meshing Code '
-! write(*,*)' Consult read_compute_parameters.f90 and auto_ner.f90 '
-! write(*,*)' This should only be invoked for chunks less than 90 degrees'
-! write(*,*)' and for chunks greater than 1248 elements wide'
-! write(*,*)
-! write(*,*)'CHUNK WIDTH: ', ANGULAR_WIDTH_XI_IN_DEGREES
-! write(*,*)'NEX: ', NEX_MAX
-! write(*,*)'NER_CRUST: ', NER_CRUST
-! write(*,*)'NER_80_MOHO: ', NER_80_MOHO
-! write(*,*)'NER_220_80: ', NER_220_80
-! write(*,*)'NER_400_220: ', NER_400_220
-! write(*,*)'NER_600_400: ', NER_600_400
-! write(*,*)'NER_670_600: ', NER_670_600
-! write(*,*)'NER_771_670: ', NER_771_670
-! write(*,*)'NER_TOPDDOUBLEPRIME_771: ', NER_TOPDDOUBLEPRIME_771
-! write(*,*)'NER_CMB_TOPDDOUBLEPRIME: ', NER_CMB_TOPDDOUBLEPRIME
-! write(*,*)'NER_OUTER_CORE: ', NER_OUTER_CORE
-! write(*,*)'NER_TOP_CENTRAL_CUBE_ICB: ', NER_TOP_CENTRAL_CUBE_ICB
-! write(*,*)'R_CENTRAL_CUBE: ', R_CENTRAL_CUBE
-! write(*,*)'multiplication factor: ', multiplication_factor
-! write(*,*)
-! write(*,*)'DT: ',DT
-! write(*,*)'MIN_ATTENUATION_PERIOD ',MIN_ATTENUATION_PERIOD
-! write(*,*)'MAX_ATTENUATION_PERIOD ',MAX_ATTENUATION_PERIOD
-! write(*,*)
-! write(*,*)'##############################################################'
-
- 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'
-
-! 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_string(LOCAL_PATH, 'LOCAL_PATH')
- 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
-
- ! 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_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(10) = .true.
- this_region_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
-
- ! 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_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(2) = .true.
- this_region_has_a_doubling(9) = .true.
- this_region_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
-
- ! 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_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(3) = .true.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- this_region_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
-
- ! 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_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- this_region_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
-
- ! 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_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(2) = .true.
- this_region_has_a_doubling(9) = .true.
- this_region_has_a_doubling(12) = .true.
- this_region_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
-
- ! 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_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(3) = .true.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- this_region_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_region_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_region_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_region_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/read_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_value_parameters.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_value_parameters.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,179 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! read values from parameter file, ignoring white lines and comments
-
- subroutine read_value_integer(value_to_read, name)
-
- implicit none
-
- integer value_to_read
- character(len=*) name
- character(len=100) string_read
-
- call unused_string(name)
-
- call read_next_line(string_read)
- read(string_read,*) value_to_read
-
- end subroutine read_value_integer
-
-!--------------------
-
- subroutine read_value_double_precision(value_to_read, name)
-
- implicit none
-
- double precision value_to_read
- character(len=*) name
- character(len=100) string_read
-
- call unused_string(name)
-
- call read_next_line(string_read)
- read(string_read,*) value_to_read
-
- end subroutine read_value_double_precision
-
-!--------------------
-
- subroutine read_value_logical(value_to_read, name)
-
- implicit none
-
- logical value_to_read
- character(len=*) name
- character(len=100) string_read
-
- call unused_string(name)
-
- call read_next_line(string_read)
- read(string_read,*) value_to_read
-
- end subroutine read_value_logical
-
-!--------------------
-
- subroutine read_value_string(value_to_read, name)
-
- implicit none
-
- character(len=*) value_to_read
- character(len=*) name
- character(len=100) string_read
-
- call unused_string(name)
-
- call read_next_line(string_read)
- value_to_read = string_read
-
- end subroutine read_value_string
-
-!--------------------
-
- subroutine read_next_line(string_read)
-
- implicit none
-
- include "constants.h"
-
- character(len=100) string_read
-
- integer index_equal_sign,ios
-
- do
- read(unit=IIN,fmt="(a100)",iostat=ios) string_read
- if(ios /= 0) stop 'error while reading parameter file'
-
-! suppress leading white spaces, if any
- string_read = adjustl(string_read)
-
-! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS)
- if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1)
-
-! exit loop when we find the first line that is not a comment or a white line
- if(len_trim(string_read) == 0) cycle
- if(string_read(1:1) /= '#') exit
-
- enddo
-
-! suppress trailing white spaces, if any
- string_read = string_read(1:len_trim(string_read))
-
-! suppress trailing comments, if any
- if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1)
-
-! suppress leading junk (up to the first equal sign, included)
- index_equal_sign = index(string_read,'=')
- if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file'
- string_read = string_read(index_equal_sign + 1:len_trim(string_read))
-
-! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk
- string_read = adjustl(string_read)
- string_read = string_read(1:len_trim(string_read))
-
- end subroutine read_next_line
-
-!--------------------
-
- subroutine open_parameter_file
-
- include "constants.h"
-
- open(unit=IIN,file='DATA/Par_file',status='old',action='read')
-
- end subroutine open_parameter_file
-
-!--------------------
-
- subroutine close_parameter_file
-
- include "constants.h"
-
- close(IIN)
-
- end subroutine close_parameter_file
-
-!--------------------
-
- integer function err_occurred()
-
- err_occurred = 0
-
- end function err_occurred
-
-!--------------------
-
-! dummy subroutine to avoid warnings about variable not used in other subroutines
- subroutine unused_string(s)
-
- character(len=*) s
-
- if (len(s) == 1) continue
-
- end subroutine unused_string
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_jacobian.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_jacobian.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,267 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! recompute 3D jacobian at a given point for 27-node elements
-
- subroutine recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
-
- implicit none
-
- include "constants.h"
-
- double precision x,y,z,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- double precision xi,eta,gamma,jacobian
-
-! coordinates of the control points of the surface element
- double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
-
-! 3D shape functions and their derivatives at receiver
- double precision shape3D(NGNOD)
- double precision dershape3D(NDIM,NGNOD)
-
- double precision l1xi,l2xi,l3xi
- double precision l1eta,l2eta,l3eta
- double precision l1gamma,l2gamma,l3gamma
- double precision l1pxi,l2pxi,l3pxi
- double precision l1peta,l2peta,l3peta
- double precision l1pgamma,l2pgamma,l3pgamma
-
- double precision xxi,yxi,zxi
- double precision xeta,yeta,zeta
- double precision xgamma,ygamma,zgamma
-
- integer ia
-
-! recompute jacobian for any given (xi,eta,gamma) point
-! not necessarily a GLL point
-
-! check that the parameter file is correct
- if(NGNOD /= 27) stop 'elements should have 27 control nodes'
-
- l1xi=HALF*xi*(xi-ONE)
- l2xi=ONE-xi**2
- l3xi=HALF*xi*(xi+ONE)
-
- l1pxi=xi-HALF
- l2pxi=-TWO*xi
- l3pxi=xi+HALF
-
- l1eta=HALF*eta*(eta-ONE)
- l2eta=ONE-eta**2
- l3eta=HALF*eta*(eta+ONE)
-
- l1peta=eta-HALF
- l2peta=-TWO*eta
- l3peta=eta+HALF
-
- l1gamma=HALF*gamma*(gamma-ONE)
- l2gamma=ONE-gamma**2
- l3gamma=HALF*gamma*(gamma+ONE)
-
- l1pgamma=gamma-HALF
- l2pgamma=-TWO*gamma
- l3pgamma=gamma+HALF
-
-! corner nodes
-
- shape3D(1)=l1xi*l1eta*l1gamma
- shape3D(2)=l3xi*l1eta*l1gamma
- shape3D(3)=l3xi*l3eta*l1gamma
- shape3D(4)=l1xi*l3eta*l1gamma
- shape3D(5)=l1xi*l1eta*l3gamma
- shape3D(6)=l3xi*l1eta*l3gamma
- shape3D(7)=l3xi*l3eta*l3gamma
- shape3D(8)=l1xi*l3eta*l3gamma
-
- dershape3D(1,1)=l1pxi*l1eta*l1gamma
- dershape3D(1,2)=l3pxi*l1eta*l1gamma
- dershape3D(1,3)=l3pxi*l3eta*l1gamma
- dershape3D(1,4)=l1pxi*l3eta*l1gamma
- dershape3D(1,5)=l1pxi*l1eta*l3gamma
- dershape3D(1,6)=l3pxi*l1eta*l3gamma
- dershape3D(1,7)=l3pxi*l3eta*l3gamma
- dershape3D(1,8)=l1pxi*l3eta*l3gamma
-
- dershape3D(2,1)=l1xi*l1peta*l1gamma
- dershape3D(2,2)=l3xi*l1peta*l1gamma
- dershape3D(2,3)=l3xi*l3peta*l1gamma
- dershape3D(2,4)=l1xi*l3peta*l1gamma
- dershape3D(2,5)=l1xi*l1peta*l3gamma
- dershape3D(2,6)=l3xi*l1peta*l3gamma
- dershape3D(2,7)=l3xi*l3peta*l3gamma
- dershape3D(2,8)=l1xi*l3peta*l3gamma
-
- dershape3D(3,1)=l1xi*l1eta*l1pgamma
- dershape3D(3,2)=l3xi*l1eta*l1pgamma
- dershape3D(3,3)=l3xi*l3eta*l1pgamma
- dershape3D(3,4)=l1xi*l3eta*l1pgamma
- dershape3D(3,5)=l1xi*l1eta*l3pgamma
- dershape3D(3,6)=l3xi*l1eta*l3pgamma
- dershape3D(3,7)=l3xi*l3eta*l3pgamma
- dershape3D(3,8)=l1xi*l3eta*l3pgamma
-
-! midside nodes
-
- shape3D(9)=l2xi*l1eta*l1gamma
- shape3D(10)=l3xi*l2eta*l1gamma
- shape3D(11)=l2xi*l3eta*l1gamma
- shape3D(12)=l1xi*l2eta*l1gamma
- shape3D(13)=l1xi*l1eta*l2gamma
- shape3D(14)=l3xi*l1eta*l2gamma
- shape3D(15)=l3xi*l3eta*l2gamma
- shape3D(16)=l1xi*l3eta*l2gamma
- shape3D(17)=l2xi*l1eta*l3gamma
- shape3D(18)=l3xi*l2eta*l3gamma
- shape3D(19)=l2xi*l3eta*l3gamma
- shape3D(20)=l1xi*l2eta*l3gamma
-
- dershape3D(1,9)=l2pxi*l1eta*l1gamma
- dershape3D(1,10)=l3pxi*l2eta*l1gamma
- dershape3D(1,11)=l2pxi*l3eta*l1gamma
- dershape3D(1,12)=l1pxi*l2eta*l1gamma
- dershape3D(1,13)=l1pxi*l1eta*l2gamma
- dershape3D(1,14)=l3pxi*l1eta*l2gamma
- dershape3D(1,15)=l3pxi*l3eta*l2gamma
- dershape3D(1,16)=l1pxi*l3eta*l2gamma
- dershape3D(1,17)=l2pxi*l1eta*l3gamma
- dershape3D(1,18)=l3pxi*l2eta*l3gamma
- dershape3D(1,19)=l2pxi*l3eta*l3gamma
- dershape3D(1,20)=l1pxi*l2eta*l3gamma
-
- dershape3D(2,9)=l2xi*l1peta*l1gamma
- dershape3D(2,10)=l3xi*l2peta*l1gamma
- dershape3D(2,11)=l2xi*l3peta*l1gamma
- dershape3D(2,12)=l1xi*l2peta*l1gamma
- dershape3D(2,13)=l1xi*l1peta*l2gamma
- dershape3D(2,14)=l3xi*l1peta*l2gamma
- dershape3D(2,15)=l3xi*l3peta*l2gamma
- dershape3D(2,16)=l1xi*l3peta*l2gamma
- dershape3D(2,17)=l2xi*l1peta*l3gamma
- dershape3D(2,18)=l3xi*l2peta*l3gamma
- dershape3D(2,19)=l2xi*l3peta*l3gamma
- dershape3D(2,20)=l1xi*l2peta*l3gamma
-
- dershape3D(3,9)=l2xi*l1eta*l1pgamma
- dershape3D(3,10)=l3xi*l2eta*l1pgamma
- dershape3D(3,11)=l2xi*l3eta*l1pgamma
- dershape3D(3,12)=l1xi*l2eta*l1pgamma
- dershape3D(3,13)=l1xi*l1eta*l2pgamma
- dershape3D(3,14)=l3xi*l1eta*l2pgamma
- dershape3D(3,15)=l3xi*l3eta*l2pgamma
- dershape3D(3,16)=l1xi*l3eta*l2pgamma
- dershape3D(3,17)=l2xi*l1eta*l3pgamma
- dershape3D(3,18)=l3xi*l2eta*l3pgamma
- dershape3D(3,19)=l2xi*l3eta*l3pgamma
- dershape3D(3,20)=l1xi*l2eta*l3pgamma
-
-! side center nodes
-
- shape3D(21)=l2xi*l2eta*l1gamma
- shape3D(22)=l2xi*l1eta*l2gamma
- shape3D(23)=l3xi*l2eta*l2gamma
- shape3D(24)=l2xi*l3eta*l2gamma
- shape3D(25)=l1xi*l2eta*l2gamma
- shape3D(26)=l2xi*l2eta*l3gamma
-
- dershape3D(1,21)=l2pxi*l2eta*l1gamma
- dershape3D(1,22)=l2pxi*l1eta*l2gamma
- dershape3D(1,23)=l3pxi*l2eta*l2gamma
- dershape3D(1,24)=l2pxi*l3eta*l2gamma
- dershape3D(1,25)=l1pxi*l2eta*l2gamma
- dershape3D(1,26)=l2pxi*l2eta*l3gamma
-
- dershape3D(2,21)=l2xi*l2peta*l1gamma
- dershape3D(2,22)=l2xi*l1peta*l2gamma
- dershape3D(2,23)=l3xi*l2peta*l2gamma
- dershape3D(2,24)=l2xi*l3peta*l2gamma
- dershape3D(2,25)=l1xi*l2peta*l2gamma
- dershape3D(2,26)=l2xi*l2peta*l3gamma
-
- dershape3D(3,21)=l2xi*l2eta*l1pgamma
- dershape3D(3,22)=l2xi*l1eta*l2pgamma
- dershape3D(3,23)=l3xi*l2eta*l2pgamma
- dershape3D(3,24)=l2xi*l3eta*l2pgamma
- dershape3D(3,25)=l1xi*l2eta*l2pgamma
- dershape3D(3,26)=l2xi*l2eta*l3pgamma
-
-! center node
-
- shape3D(27)=l2xi*l2eta*l2gamma
-
- dershape3D(1,27)=l2pxi*l2eta*l2gamma
- dershape3D(2,27)=l2xi*l2peta*l2gamma
- dershape3D(3,27)=l2xi*l2eta*l2pgamma
-
-! compute coordinates and jacobian matrix
- x=ZERO
- y=ZERO
- z=ZERO
- xxi=ZERO
- xeta=ZERO
- xgamma=ZERO
- yxi=ZERO
- yeta=ZERO
- ygamma=ZERO
- zxi=ZERO
- zeta=ZERO
- zgamma=ZERO
-
- do ia=1,NGNOD
- x=x+shape3D(ia)*xelm(ia)
- y=y+shape3D(ia)*yelm(ia)
- z=z+shape3D(ia)*zelm(ia)
-
- xxi=xxi+dershape3D(1,ia)*xelm(ia)
- xeta=xeta+dershape3D(2,ia)*xelm(ia)
- xgamma=xgamma+dershape3D(3,ia)*xelm(ia)
- yxi=yxi+dershape3D(1,ia)*yelm(ia)
- yeta=yeta+dershape3D(2,ia)*yelm(ia)
- ygamma=ygamma+dershape3D(3,ia)*yelm(ia)
- zxi=zxi+dershape3D(1,ia)*zelm(ia)
- zeta=zeta+dershape3D(2,ia)*zelm(ia)
- zgamma=zgamma+dershape3D(3,ia)*zelm(ia)
- enddo
-
- jacobian = xxi*(yeta*zgamma-ygamma*zeta) - xeta*(yxi*zgamma-ygamma*zxi) + &
- xgamma*(yxi*zeta-yeta*zxi)
-
- if(jacobian <= ZERO) stop '3D Jacobian undefined'
-
-! invert the relation (Fletcher p. 50 vol. 2)
- xix=(yeta*zgamma-ygamma*zeta)/jacobian
- xiy=(xgamma*zeta-xeta*zgamma)/jacobian
- xiz=(xeta*ygamma-xgamma*yeta)/jacobian
- etax=(ygamma*zxi-yxi*zgamma)/jacobian
- etay=(xxi*zgamma-xgamma*zxi)/jacobian
- etaz=(xgamma*yxi-xxi*ygamma)/jacobian
- gammax=(yxi*zeta-yeta*zxi)/jacobian
- gammay=(xeta*zxi-xxi*zeta)/jacobian
- gammaz=(xxi*yeta-xeta*yxi)/jacobian
-
- end subroutine recompute_jacobian
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_missing_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_missing_arrays.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_missing_arrays.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,202 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-!! DK DK added this for merged version
- subroutine recompute_missing_arrays(myrank, &
- xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- xstore,ystore,zstore, &
- xelm_store,yelm_store,zelm_store,ibool,nspec,nglob)
-
- implicit none
-
- include "constants.h"
-
- integer nspec,nglob,myrank
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
- real(kind=CUSTOM_REAL), dimension(NGNOD,nspec) :: xelm_store,yelm_store,zelm_store
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
-
- integer i,j,k,ia,ispec
-
- double precision xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
- double precision xmesh,ymesh,zmesh
- double precision xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- double precision jacobian
-
-! Gauss-Lobatto-Legendre points and weights of integration
- double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
-
-! 3D shape functions and their derivatives
- double precision, dimension(:,:,:,:), allocatable :: shape3D
- double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
-
-! Gauss-Lobatto-Legendre points of integration
- allocate(xigll(NGLLX))
- allocate(yigll(NGLLY))
- allocate(zigll(NGLLZ))
-
-! Gauss-Lobatto-Legendre weights of integration
- allocate(wxgll(NGLLX))
- allocate(wygll(NGLLY))
- allocate(wzgll(NGLLZ))
-
-! 3D shape functions and their derivatives
- allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ))
- allocate(dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ))
-
-! 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)
-
- do ispec = 1,nspec
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- xxi = ZERO
- xeta = ZERO
- xgamma = ZERO
- yxi = ZERO
- yeta = ZERO
- ygamma = ZERO
- zxi = ZERO
- zeta = ZERO
- zgamma = ZERO
- xmesh = ZERO
- ymesh = ZERO
- zmesh = ZERO
-
- do ia=1,NGNOD
- if(CUSTOM_REAL == SIZE_REAL) then
- xxi = xxi + dershape3D(1,ia,i,j,k)*dble(xelm_store(ia,ispec))
- xeta = xeta + dershape3D(2,ia,i,j,k)*dble(xelm_store(ia,ispec))
- xgamma = xgamma + dershape3D(3,ia,i,j,k)*dble(xelm_store(ia,ispec))
- yxi = yxi + dershape3D(1,ia,i,j,k)*dble(yelm_store(ia,ispec))
- yeta = yeta + dershape3D(2,ia,i,j,k)*dble(yelm_store(ia,ispec))
- ygamma = ygamma + dershape3D(3,ia,i,j,k)*dble(yelm_store(ia,ispec))
- zxi = zxi + dershape3D(1,ia,i,j,k)*dble(zelm_store(ia,ispec))
- zeta = zeta + dershape3D(2,ia,i,j,k)*dble(zelm_store(ia,ispec))
- zgamma = zgamma + dershape3D(3,ia,i,j,k)*dble(zelm_store(ia,ispec))
- xmesh = xmesh + shape3D(ia,i,j,k)*dble(xelm_store(ia,ispec))
- ymesh = ymesh + shape3D(ia,i,j,k)*dble(yelm_store(ia,ispec))
- zmesh = zmesh + shape3D(ia,i,j,k)*dble(zelm_store(ia,ispec))
- else
- xxi = xxi + dershape3D(1,ia,i,j,k)*xelm_store(ia,ispec)
- xeta = xeta + dershape3D(2,ia,i,j,k)*xelm_store(ia,ispec)
- xgamma = xgamma + dershape3D(3,ia,i,j,k)*xelm_store(ia,ispec)
- yxi = yxi + dershape3D(1,ia,i,j,k)*yelm_store(ia,ispec)
- yeta = yeta + dershape3D(2,ia,i,j,k)*yelm_store(ia,ispec)
- ygamma = ygamma + dershape3D(3,ia,i,j,k)*yelm_store(ia,ispec)
- zxi = zxi + dershape3D(1,ia,i,j,k)*zelm_store(ia,ispec)
- zeta = zeta + dershape3D(2,ia,i,j,k)*zelm_store(ia,ispec)
- zgamma = zgamma + dershape3D(3,ia,i,j,k)*zelm_store(ia,ispec)
- xmesh = xmesh + shape3D(ia,i,j,k)*xelm_store(ia,ispec)
- ymesh = ymesh + shape3D(ia,i,j,k)*yelm_store(ia,ispec)
- zmesh = zmesh + shape3D(ia,i,j,k)*zelm_store(ia,ispec)
- endif
- enddo
-
- jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
- xeta*(yxi*zgamma-ygamma*zxi) + &
- xgamma*(yxi*zeta-yeta*zxi)
-
- if(jacobian <= ZERO) call exit_MPI(myrank,'3D Jacobian undefined when recomputing missing arrays')
-
-! invert the relation (Fletcher p. 50 vol. 2)
- xix = (yeta*zgamma-ygamma*zeta) / jacobian
- xiy = (xgamma*zeta-xeta*zgamma) / jacobian
- xiz = (xeta*ygamma-xgamma*yeta) / jacobian
- etax = (ygamma*zxi-yxi*zgamma) / jacobian
- etay = (xxi*zgamma-xgamma*zxi) / jacobian
- etaz = (xgamma*yxi-xxi*ygamma) / jacobian
- gammax = (yxi*zeta-yeta*zxi) / jacobian
- gammay = (xeta*zxi-xxi*zeta) / jacobian
- gammaz = (xxi*yeta-xeta*yxi) / jacobian
-
-! save the derivatives and the jacobian
-! store mesh coordinates
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- xixstore(i,j,k,ispec) = sngl(xix)
- xiystore(i,j,k,ispec) = sngl(xiy)
- xizstore(i,j,k,ispec) = sngl(xiz)
- etaxstore(i,j,k,ispec) = sngl(etax)
- etaystore(i,j,k,ispec) = sngl(etay)
- etazstore(i,j,k,ispec) = sngl(etaz)
- gammaxstore(i,j,k,ispec) = sngl(gammax)
- gammaystore(i,j,k,ispec) = sngl(gammay)
- gammazstore(i,j,k,ispec) = sngl(gammaz)
-
- xstore(ibool(i,j,k,ispec)) = sngl(xmesh)
- ystore(ibool(i,j,k,ispec)) = sngl(ymesh)
- zstore(ibool(i,j,k,ispec)) = sngl(zmesh)
- else
- xixstore(i,j,k,ispec) = xix
- xiystore(i,j,k,ispec) = xiy
- xizstore(i,j,k,ispec) = xiz
- etaxstore(i,j,k,ispec) = etax
- etaystore(i,j,k,ispec) = etay
- etazstore(i,j,k,ispec) = etaz
- gammaxstore(i,j,k,ispec) = gammax
- gammaystore(i,j,k,ispec) = gammay
- gammazstore(i,j,k,ispec) = gammaz
-
- xstore(ibool(i,j,k,ispec)) = xmesh
- ystore(ibool(i,j,k,ispec)) = ymesh
- zstore(ibool(i,j,k,ispec)) = zmesh
- endif
-
- enddo
- enddo
- enddo
-
- enddo
-
- deallocate(xigll,yigll,zigll)
- deallocate(wxgll,wygll,wzgll)
- deallocate(shape3D,dershape3D)
-
- end subroutine recompute_missing_arrays
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/reduce.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/reduce.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/reduce.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,84 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 reduce(theta,phi)
-
-! bring theta between 0 and PI, and phi between 0 and 2*PI
-
- implicit none
-
- include "constants.h"
-
- double precision theta,phi
-
- integer i
- double precision th,ph
-
- th=theta
- ph=phi
- i=abs(int(ph/TWO_PI))
- if(ph<ZERO) then
- ph=ph+(i+1)*TWO_PI
- else
- if(ph>TWO_PI) ph=ph-i*TWO_PI
- endif
- phi=ph
- if(th<ZERO .or. th>PI) then
- i=int(th/PI)
- if(th>ZERO) then
- if(mod(i,2) /= 0) then
- th=(i+1)*PI-th
- if(ph<PI) then
- ph=ph+PI
- else
- ph=ph-PI
- endif
- else
- th=th-i*PI
- endif
- else
- if(mod(i,2) == 0) then
- th=-th+i*PI
- if(ph<PI) then
- ph=ph+PI
- else
- ph=ph-PI
- endif
- else
- th=th-i*PI
- endif
- endif
- theta=th
- phi=ph
- endif
-
- if(theta<ZERO .or. theta>PI) stop 'theta out of range in reduce'
-
- if(phi<ZERO .or. phi>TWO_PI) stop 'phi out of range in reduce'
-
- end subroutine reduce
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/remap_lsf_machines.pl
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/remap_lsf_machines.pl 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/remap_lsf_machines.pl 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,20 +0,0 @@
-#!/usr/bin/perl -w
-
-if (@ARGV != 1) {die("remap_lsf_machines.pl machinefile\n");}
-
-$machine = $ARGV[0];
-
-open(FILE,"$machine") or die("Error opening file $machine\n");
-(@junk) = <FILE>;
-close(FILE);
-
-for($i=0;$i<@junk;$i++) {
- @node_array = split(" ",$junk[$i]);
- foreach $node (@node_array) {
- next if ( $node =~ /^[0-9]/ );
- push(@nodes, $node);
- }
-}
-foreach $node (@nodes) {
- print "$node\n";
-}
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/rthetaphi_xyz.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/rthetaphi_xyz.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/rthetaphi_xyz.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,119 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 xyz_2_rthetaphi(x,y,z,r,theta,phi)
-
-! convert x y z to r theta phi, single precision call
-
- implicit none
-
- include "constants.h"
-
- real(kind=CUSTOM_REAL) x,y,z,r,theta,phi
- double precision xmesh,ymesh,zmesh
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
-
- xmesh = dble(x)
- ymesh = dble(y)
- zmesh = dble(z)
-
- if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
- if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
- theta = sngl(datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh))
- if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
- if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
- phi = sngl(datan2(ymesh,xmesh))
-
- r = sngl(dsqrt(xmesh**2 + ymesh**2 + zmesh**2))
-
- else
-
- xmesh = x
- ymesh = y
- zmesh = z
-
- if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
- if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
- theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
- if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
- if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
- phi = datan2(ymesh,xmesh)
-
- r = dsqrt(xmesh**2 + ymesh**2 + zmesh**2)
-
- endif
-
- end subroutine xyz_2_rthetaphi
-
-!-------------------------------------------------------------
-
- subroutine xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
-
-! convert x y z to r theta phi, double precision call
-
- implicit none
-
- include "constants.h"
-
- double precision x,y,z,r,theta,phi
- double precision xmesh,ymesh,zmesh
-
- xmesh = x
- ymesh = y
- zmesh = z
-
- if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
- if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
- theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
- if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
- if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
- phi = datan2(ymesh,xmesh)
-
- r = dsqrt(xmesh**2 + ymesh**2 + zmesh**2)
-
- end subroutine xyz_2_rthetaphi_dble
-
-!-------------------------------------------------------------
-
- subroutine rthetaphi_2_xyz(x,y,z,r,theta,phi)
-
-! convert r theta phi to x y z
-
- implicit none
-
- include "constants.h"
-
- real(kind=CUSTOM_REAL) x,y,z,r,theta,phi
-
- x = r * sin(theta) * cos(phi)
- y = r * sin(theta) * sin(phi)
- z = r * cos(theta)
-
- end subroutine rthetaphi_2_xyz
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/run_lsf_globe_big.bash
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/run_lsf_globe_big.bash 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/run_lsf_globe_big.bash 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,21 +0,0 @@
-#!/bin/bash
-
-# use the normal queue unless otherwise directed
-queue="-q normal"
-if [ $# -eq 1 ]; then
- echo "Setting the queue to $1"
- queue="-q $1"
-fi
-
-# compute total number of nodes needed
-NPROC_XI=`grep NPROC_XI DATA/Par_file | cut -d = -f 2`
-NPROC_ETA=`grep NPROC_ETA DATA/Par_file | cut -d = -f 2 `
-NCHUNKS=`grep NCHUNKS DATA/Par_file | cut -d = -f 2`
-
-# total number of nodes is the product of the values read
-numnodes=$(( $NCHUNKS * $NPROC_XI * $NPROC_ETA ))
-
-echo "Submitting job"
-bsub $queue -n $numnodes -W 14:00 -C 0 < go_mesher_solver_lsf_globe.bash
-#bsub $queue -n $numnodes -W 144:00 -C 0 < go_mesher_solver_lsf_globe.bash
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/s362ani.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/s362ani.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/s362ani.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,1784 +0,0 @@
-
- subroutine evradker(depth,string,nker,vercof,dvercof,ierror)
-
- implicit none
-
- integer :: nker,ierror
-
- real(kind=4) :: chebyshev(100)
- real(kind=4) :: chebyshev2(100)
- real(kind=4) :: vercof(nker)
- real(kind=4) :: dvercof(nker)
- real(kind=4) :: splpts(100)
-
- character(len=80) string
-
- logical upper,upper_650
- logical lower,lower_650
-
- real(kind=4), parameter :: r0=6371.
- real(kind=4), parameter :: rmoho=6371.0-24.4
- real(kind=4), parameter :: r670=6371.-670.
- real(kind=4), parameter :: r650=6371.-650.
- real(kind=4), parameter :: rcmb=3480.0
-
- integer :: i,nspl,nskip,nlower,nupper,iker,lstr
-
- real(kind=4) :: u,u2,ddep,radius2,radius,depth
-
- ierror=0
- lstr=len_trim(string)
-
- radius=r0-depth
- ddep=0.1
- radius2=r0-depth+ddep
- upper=.false.
- lower=.false.
- if(radius > rcmb.and.radius < r670) then
- lower=.true.
- else if(radius >= r670.and.radius < rmoho) then
- upper=.true.
- endif
- upper_650=.false.
- lower_650=.false.
- if(radius > rcmb.and.radius < r650) then
- lower_650=.true.
- else if(radius >= r650.and.radius < rmoho) then
- upper_650=.true.
- endif
- do iker=1,nker
- vercof(iker)=0.
- dvercof(iker)=0.
- enddo
-
- if(string(1:16) == 'WDC+SPC_U4L8CHEB') then
- nupper=5
- nlower=9
- nskip=2
- if(upper) then
- u=(radius+radius-rmoho-r670)/(rmoho-r670)
- u2=(radius2+radius2-rmoho-r670)/(rmoho-r670)
-! write(6,"('upper mantle:',2f10.3)") u,u2
- call chebyfun(u,13,chebyshev)
- do i=1+nskip,nskip+nupper
- vercof(i)=chebyshev(i-nskip)
- enddo
- call chebyfun(u2,13,chebyshev2)
- do i=1+nskip,nskip+nupper
- dvercof(i)=(chebyshev2(i-nskip)-chebyshev(i-nskip))/ddep
- enddo
- else if(lower) then
- u=(radius+radius-r670-rcmb)/(r670-rcmb)
- u2=(radius2+radius2-r670-rcmb)/(r670-rcmb)
-! write(6,"('lower mantle:',2f10.3)") u,u2
- call chebyfun(u,13,chebyshev)
- do i=1+nskip+nupper,nskip+nupper+nlower
- vercof(i)=chebyshev(i-nskip-nupper)
- enddo
- call chebyfun(u2,13,chebyshev2)
- do i=1+nskip+nupper,nskip+nupper+nlower
- dvercof(i)=(chebyshev2(i-nskip-nupper)- &
- chebyshev(i-nskip-nupper))/ddep
- enddo
- endif
- else if(string(1:13) == 'WDC+SHSVWM20A') then
- nspl=20
- splpts(1)=0.
- splpts(2)=50.
- splpts(3)=100.
- splpts(4)=150.
- splpts(5)=200.
- splpts(6)=250.
- splpts(7)=300.
- splpts(8)=400.
- splpts(9)=500.
- splpts(10)=600.
- splpts(11)=700.
- splpts(12)=850.
- splpts(13)=1050.
- splpts(14)=1300.
- splpts(15)=1600.
- splpts(16)=1900.
- splpts(17)=2200.
- splpts(18)=2500.
- splpts(19)=2700.
- splpts(20)=2891.
- call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
- do i=22,27
- vercof(i)=vercof(i-20)
- dvercof(i)=dvercof(i-20)
- enddo
- vercof(1)=1.
- else if(string(1:16) == 'WDC+XBS_362_U6L8') then
- if(upper) then
- nspl=6
- splpts(1)=24.4
- splpts(2)=100.
- splpts(3)=225.
- splpts(4)=350.
- splpts(5)=500.
- splpts(6)=670.
- call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
- else if(lower) then
- nspl=8
- splpts(1)=670.
- splpts(2)=820.
- splpts(3)=1320.
- splpts(4)=1820.
- splpts(5)=2320.
- splpts(6)=2550.
- splpts(7)=2791.
- splpts(8)=2891.
- call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
- endif
- vercof(1)=1.
-! vercof(16)=1.
-! vercof(17)=1.
-! else if(string(1:21) == 'WDC+ANI_362_U6L8_TOPO') then
-! if(upper) then
-! nspl=6
-! splpts(1)=24.4
-! splpts(2)=100.
-! splpts(3)=225.
-! splpts(4)=350.
-! splpts(5)=500.
-! splpts(6)=670.
-! call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
-! do i=16,21
-! vercof(i)=vercof(i-14)
-! dvercof(i)=dvercof(i-14)
-! enddo
-! else if(lower) then
-! nspl=8
-! splpts(1)=670.
-! splpts(2)=820.
-! splpts(3)=1320.
-! splpts(4)=1820.
-! splpts(5)=2320.
-! splpts(6)=2550.
-! splpts(7)=2791.
-! splpts(8)=2891.
-! call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
-! endif
-! vercof(1)=1.
-! vercof(22)=1.
-! vercof(23)=1.
-! vercof(24)=1.
-! vercof(25)=1.
- else if( &
- (string(1:lstr) == 'WDC+ANI_362_U6L8'.and.lstr == 16) &
- .or. &
- (string(1:lstr) == 'WDC+ANI_362_U6L8_TOPO'.and.lstr == 21) &
- ) then
- if(upper) then
- nspl=6
- splpts(1)=24.4
- splpts(2)=100.
- splpts(3)=225.
- splpts(4)=350.
- splpts(5)=500.
- splpts(6)=670.
- call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
- do i=16,21
- vercof(i)=vercof(i-14)
- dvercof(i)=dvercof(i-14)
- enddo
- else if(lower) then
- nspl=8
- splpts(1)=670.
- splpts(2)=820.
- splpts(3)=1320.
- splpts(4)=1820.
- splpts(5)=2320.
- splpts(6)=2550.
- splpts(7)=2791.
- splpts(8)=2891.
- call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
- endif
- vercof(1)=1.
- vercof(22)=1.
- vercof(23)=1.
- else if(string(1:lstr) == 'WDC+WM_362_U6L8'.and.lstr == 15) then
- if(upper) then
- nspl=6
- splpts(1)=24.4
- splpts(2)=100.
- splpts(3)=225.
- splpts(4)=350.
- splpts(5)=500.
- splpts(6)=670.
- call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
- do i=16,21
- vercof(i)=vercof(i-14)
- dvercof(i)=dvercof(i-14)
- enddo
- else if(lower) then
- nspl=8
- splpts(1)=670.
- splpts(2)=820.
- splpts(3)=1320.
- splpts(4)=1820.
- splpts(5)=2320.
- splpts(6)=2550.
- splpts(7)=2791.
- splpts(8)=2891.
- call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
- do i=22,29
- vercof(i)=vercof(i-14)
- dvercof(i)=dvercof(i-14)
- enddo
- endif
- vercof(1)=1.
- vercof(30)=1.
- vercof(31)=1.
- vercof(32)=1.
- else if( &
- (string(1:lstr) == 'WDC+ANI_362_U6L8_650'.and.lstr == 20) &
- .or. &
- (string(1:lstr) == 'WDC+ANI_362_U6L8_TOPO_650'.and.lstr == 25) &
- ) then
- if(upper_650) then
- nspl=6
- splpts(1)=24.4
- splpts(2)=100.
- splpts(3)=225.
- splpts(4)=350.
- splpts(5)=500.
- splpts(6)=650.
- call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
- do i=16,21
- vercof(i)=vercof(i-14)
- dvercof(i)=dvercof(i-14)
- enddo
- else if(lower_650) then
- nspl=8
- splpts(1)=650.
- splpts(2)=820.
- splpts(3)=1320.
- splpts(4)=1820.
- splpts(5)=2320.
- splpts(6)=2550.
- splpts(7)=2791.
- splpts(8)=2891.
- call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
- endif
- vercof(1)=1.
- vercof(22)=1.
- vercof(23)=1.
- else if(string(1:lstr) == 'WDC+WM_362_U6L8_650' &
- .and.lstr == 19) then
- if(upper_650) then
- nspl=6
- splpts(1)=24.4
- splpts(2)=100.
- splpts(3)=225.
- splpts(4)=350.
- splpts(5)=500.
- splpts(6)=650.
- call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
- do i=16,21
- vercof(i)=vercof(i-14)
- dvercof(i)=dvercof(i-14)
- enddo
- else if(lower_650) then
- nspl=8
- splpts(1)=650.
- splpts(2)=820.
- splpts(3)=1320.
- splpts(4)=1820.
- splpts(5)=2320.
- splpts(6)=2550.
- splpts(7)=2791.
- splpts(8)=2891.
- call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
- do i=22,29
- vercof(i)=vercof(i-14)
- dvercof(i)=dvercof(i-14)
- enddo
- endif
- vercof(1)=1.
- vercof(30)=1.
- vercof(31)=1.
- vercof(32)=1.
- else if(string(1:lstr) == 'WDC+U8L8_650'.and.lstr == 12) then
- if(upper_650) then
- nspl=8
- splpts(1)=24.4
- splpts(2)=75.
- splpts(3)=150.
- splpts(4)=225.
- splpts(5)=300.
- splpts(6)=410.
- splpts(7)=530.
- splpts(8)=650.
- call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
- do i=18,25
- vercof(i)=vercof(i-16)
- dvercof(i)=dvercof(i-16)
- enddo
- else if(lower_650) then
- nspl=8
- splpts(1)=650.
- splpts(2)=820.
- splpts(3)=1320.
- splpts(4)=1820.
- splpts(5)=2320.
- splpts(6)=2550.
- splpts(7)=2791.
- splpts(8)=2891.
- call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
- do i=26,33
- vercof(i)=vercof(i-16)
- dvercof(i)=dvercof(i-16)
- enddo
- endif
- vercof(1)=1.
- vercof(34)=1.
- vercof(35)=1.
- vercof(36)=1.
- else if(string(1:lstr) == 'WDC+U8L8_670'.and.lstr == 12) then
- if(upper) then
- nspl=8
- splpts(1)=24.4
- splpts(2)=75.
- splpts(3)=150.
- splpts(4)=225.
- splpts(5)=300.
- splpts(6)=410.
- splpts(7)=530.
- splpts(8)=670.
- call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
- do i=18,25
- vercof(i)=vercof(i-16)
- dvercof(i)=dvercof(i-16)
- enddo
- else if(lower) then
- nspl=8
- splpts(1)=670.
- splpts(2)=820.
- splpts(3)=1320.
- splpts(4)=1820.
- splpts(5)=2320.
- splpts(6)=2550.
- splpts(7)=2791.
- splpts(8)=2891.
- call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
- do i=26,33
- vercof(i)=vercof(i-16)
- dvercof(i)=dvercof(i-16)
- enddo
- endif
- vercof(1)=1.
- vercof(34)=1.
- vercof(35)=1.
- vercof(36)=1.
- else if( &
- (string(1:lstr) == 'WDC+U8L8_I1D_650'.and.lstr == 16) &
- .or. &
- (string(1:lstr) == 'WDC+U8L8_I3D_650'.and.lstr == 16) &
- ) then
- if(upper_650) then
- nspl=8
- splpts(1)=24.4
- splpts(2)=75.
- splpts(3)=150.
- splpts(4)=225.
- splpts(5)=300.
- splpts(6)=410.
- splpts(7)=530.
- splpts(8)=650.
- call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
- do i=18,25
- vercof(i)=vercof(i-16)
- dvercof(i)=dvercof(i-16)
- enddo
- do i=37,40
- vercof(i)=vercof(i-35)
- dvercof(i)=dvercof(i-35)
- enddo
- do i=41,44
- vercof(i)=vercof(i-39)
- dvercof(i)=dvercof(i-39)
- enddo
- do i=45,48
- vercof(i)=vercof(i-43)
- dvercof(i)=dvercof(i-43)
- enddo
- do i=49,52
- vercof(i)=vercof(i-47)
- dvercof(i)=dvercof(i-47)
- enddo
- else if(lower_650) then
- nspl=8
- splpts(1)=650.
- splpts(2)=820.
- splpts(3)=1320.
- splpts(4)=1820.
- splpts(5)=2320.
- splpts(6)=2550.
- splpts(7)=2791.
- splpts(8)=2891.
- call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
- do i=26,33
- vercof(i)=vercof(i-16)
- dvercof(i)=dvercof(i-16)
- enddo
- endif
- vercof(1)=1.
- vercof(34)=1.
- vercof(35)=1.
- vercof(36)=1.
- else if((string(1:lstr) == 'WDC+I1D_650'.and.lstr == 11).or. &
- (string(1:lstr) == 'WDC+I3D_650'.and.lstr == 11)) then
- if(upper_650) then
- nspl=8
- splpts(1)=24.4
- splpts(2)=75.
- splpts(3)=150.
- splpts(4)=225.
- splpts(5)=300.
- splpts(6)=410.
- splpts(7)=530.
- splpts(8)=650.
- call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
- do i=18,25
- vercof(i)=vercof(i-16)
- dvercof(i)=dvercof(i-16)
- enddo
- do i=37,44
- vercof(i)=vercof(i-35)
- dvercof(i)=dvercof(i-35)
- enddo
- do i=53,60
- vercof(i)=vercof(i-51)
- dvercof(i)=dvercof(i-51)
- enddo
- do i=69,76
- vercof(i)=vercof(i-67)
- dvercof(i)=dvercof(i-67)
- enddo
- do i=85,92
- vercof(i)=vercof(i-83)
- dvercof(i)=dvercof(i-83)
- enddo
- else if(lower_650) then
- nspl=8
- splpts(1)=650.
- splpts(2)=820.
- splpts(3)=1320.
- splpts(4)=1820.
- splpts(5)=2320.
- splpts(6)=2550.
- splpts(7)=2791.
- splpts(8)=2891.
- call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
- do i=26,33
- vercof(i)=vercof(i-16)
- dvercof(i)=dvercof(i-16)
- enddo
- do i=45,52
- vercof(i)=vercof(i-35)
- dvercof(i)=dvercof(i-35)
- enddo
- do i=61,68
- vercof(i)=vercof(i-51)
- dvercof(i)=dvercof(i-51)
- enddo
- do i=77,84
- vercof(i)=vercof(i-67)
- dvercof(i)=dvercof(i-67)
- enddo
- do i=93,100
- vercof(i)=vercof(i-83)
- dvercof(i)=dvercof(i-83)
- enddo
- endif
- vercof(1)=1.
- vercof(34)=1.
- vercof(35)=1.
- vercof(36)=1.
- else if(string(1:lstr) == 'V16A4_V7A4'.and.lstr == 10) then
- if(upper_650) then
- nspl=8
- splpts(1)=24.4
- splpts(2)=75.
- splpts(3)=150.
- splpts(4)=225.
- splpts(5)=300.
- splpts(6)=410.
- splpts(7)=530.
- splpts(8)=650.
- call vbspl(depth,nspl,splpts,vercof(1),dvercof(1))
- do i=17,20
- vercof(i)=vercof(i-16)
- dvercof(i)=dvercof(i-16)
- enddo
- do i=23,29
- vercof(i)=vercof(i-22)
- dvercof(i)=dvercof(i-22)
- enddo
- do i=30,33
- vercof(i)=vercof(i-29)
- dvercof(i)=dvercof(i-29)
- enddo
- else if(lower_650) then
- nspl=8
- splpts(1)=650.
- splpts(2)=820.
- splpts(3)=1320.
- splpts(4)=1820.
- splpts(5)=2320.
- splpts(6)=2550.
- splpts(7)=2791.
- splpts(8)=2891.
- call vbspl(depth,nspl,splpts,vercof(9),dvercof(9))
- endif
- vercof(21)=1.
- vercof(22)=1.
- else
- write(6,"('problem 4')")
- write(6,"(a)")string(1:len_trim(string))
- stop
- endif
-
- end subroutine evradker
-
-! ---
-
- subroutine chebyfun(u,kmax,f)
-
- implicit none
-
- integer :: kmax
-
- real(kind=4) :: chebycoeff(0:13),f(0:kmax),u
-
- integer :: k
-
- real(kind=4) :: twou
-
- data chebycoeff / &
- 0.70710678118655,1.2247448713916,1.0350983390135,1.0145993123918, &
- 1.00803225754840,1.0050890913907,1.0035149493262,1.0025740068320, &
- 1.00196657023780,1.0015515913133,1.0012554932754,1.0010368069141, &
- 1.00087070107920,1.0007415648034 /
-
- if(kmax > 13)then
- write(*,"(' kmax exceeds the limit in chebyfun')")
- stop
- endif
-
- f(0)=1.0
- f(1)=u
- twou=2.0*u
-
- do k=2,kmax
- f(k) = twou*f(k-1)-f(k-2)
- enddo
-
- do k=0,kmax
- f(k)=f(k)*chebycoeff(k)
- enddo
-
- end subroutine chebyfun
-
-
- subroutine gt3dmodl(lu,targetfile, &
- maxhpa,maxker,maxcoe, &
- numhpa,numker,numcoe,lmxhpa, &
- ihpakern,itypehpa,coe, &
- itpspl,xlatspl,xlonspl,radispl, &
- numvar,ivarkern,varstr, &
- refmdl,kerstr,hsplfl,dskker,ierror)
-
- implicit none
-
- integer, parameter :: mxhpar=2
- integer, parameter :: mxkern=200
- integer, parameter :: mxcoef=2000
-
- character(len=80) refmodel
- character(len=80) kernstri
- character(len=40) desckern(mxkern)
- character(len=80) hsplfile(mxhpar)
-
- integer ihorpar(mxkern)
- integer ityphpar(mxhpar)
- integer ixlspl(mxcoef,mxhpar)
- integer lmaxhor(mxhpar)
- integer ncoefhor(mxhpar)
-
- real(kind=4) coef(mxcoef,mxkern)
- real(kind=4) xlaspl(mxcoef,mxhpar)
- real(kind=4) xlospl(mxcoef,mxhpar)
- real(kind=4) xraspl(mxcoef,mxhpar)
-
- character(len=128) targetfile
-
- integer numhpa,numker,maxhpa,maxker,maxcoe
-
- integer numcoe(maxhpa)
- integer lmxhpa(maxhpa)
- integer ihpakern(maxker)
- integer itypehpa(maxhpa)
- integer itpspl(maxcoe,maxhpa)
- integer ivarkern(maxker)
-
- real(kind=4) coe(maxcoe,maxker)
- real(kind=4) xlatspl(maxcoe,maxhpa)
- real(kind=4) xlonspl(maxcoe,maxhpa)
- real(kind=4) radispl(maxcoe,maxhpa)
-
- character(len=80) refmdl
- character(len=80) kerstr
- character(len=80) hsplfl(maxhpa)
- character(len=40) dskker(maxker)
- character(len=40) string
- character(len=40) varstr(maxker)
-
- integer numvar,ierror,lu,nhorpar,nmodkern,i,j,lstr,k
-
- ierror=0
- call rd3dmodl(lu,targetfile,ierror, &
- nmodkern,nhorpar,ityphpar, &
- ihorpar,lmaxhor,ncoefhor, &
- xlaspl,xlospl,xraspl,ixlspl,coef, &
- hsplfile,refmodel,kernstri,desckern)
-
- if(nhorpar <= maxhpa) then
- numhpa=nhorpar
- else
- ierror=ierror+1
- endif
-
- if(nmodkern <= maxker) then
- numker=nmodkern
- else
- ierror=ierror+1
- endif
-
- do i=1,nmodkern
- ihpakern(i)=ihorpar(i)
- dskker(i)=desckern(i)
- do j=1,ncoefhor(ihpakern(i))
- coe(j,i)=coef(j,i)
-! if(j == 1) then
-! write(6,"(e12.4)") coe(j,i)
-! endif
- enddo
- enddo
-
- do i=1,nhorpar
- numcoe(i)=ncoefhor(i)
- lmxhpa(i)=lmaxhor(i)
- itypehpa(i)=ityphpar(i)
- if(itypehpa(i) == 2) then
- do j=1,ncoefhor(i)
- itpspl(j,i)=ixlspl(j,i)
- xlatspl(j,i)=xlaspl(j,i)
- xlonspl(j,i)=xlospl(j,i)
- radispl(j,i)=xraspl(j,i)
- enddo
- endif
- hsplfl(i)=hsplfile(i)
- enddo
-
- numvar=0
- do i=1,nmodkern
- string=dskker(i)
- lstr=len_trim(string)
- j=1
- do while(string(j:j) /= ','.and.j < lstr)
- j=j+1
- enddo
- ivarkern(i)=0
- do k=1,numvar
- if(string(1:j) == varstr(k)(1:j)) then
- ivarkern(i)=k
- endif
- enddo
- if(ivarkern(i) == 0) then
- numvar=numvar+1
- varstr(numvar)=string(1:j)
- ivarkern(i)=numvar
- endif
- enddo
-
- refmdl=refmodel
- kerstr=kernstri
-
- end subroutine gt3dmodl
-
-
- subroutine rd3dmodl(lu,filename,ierror, &
- nmodkern,nhorpar,ityphpar, &
- ihorpar,lmaxhor,ncoefhor, &
- xlaspl,xlospl,xraspl,ixlspl,coef, &
- hsplfile,refmodel,kernstri,desckern)
-
- implicit none
-
- integer, parameter :: mxhpar=2
- integer, parameter :: mxkern=200
- integer, parameter :: mxcoef=2000
-
- character(len=80) refmodel
- character(len=80) kernstri
- character(len=40) desckern(mxkern)
- character(len=80) hsplfile(mxhpar)
-
- integer ihorpar(mxkern)
- integer ityphpar(mxhpar)
- integer ixlspl(mxcoef,mxhpar)
- integer lmaxhor(mxhpar)
- integer ncoefhor(mxhpar)
-
- real(kind=4) coef(mxcoef,mxkern)
- real(kind=4) xlaspl(mxcoef,mxhpar)
- real(kind=4) xlospl(mxcoef,mxhpar)
- real(kind=4) xraspl(mxcoef,mxhpar)
-
- character(len=128) filename
-
- character(len=128) string
- character(len=128) substr
-
- integer :: lu,ierror
-
- integer :: ncoef,i,ihor,ifst,ilst,ifst1,ios,lstr,nmodkern,idummy,nhorpar,lmax
-
- open(lu,file=filename,iostat=ios)
- if(ios /= 0) then
- stop 'error opening 3-d model'
- endif
- do while (ios == 0)
- read(lu,"(a)",iostat=ios) string
- lstr=len_trim(string)
- if(ios == 0) then
- if(string(1:16) == 'REFERENCE MODEL:') then
- substr=string(17:lstr)
- ifst=1
- ilst=len_trim(substr)
- do while (substr(ifst:ifst) == ' '.and.ifst < ilst)
- ifst=ifst+1
- enddo
- if(ilst-ifst <= 0) then
- stop 'error reading model 1'
- else
- refmodel=substr(ifst:ilst)
- endif
- else if(string(1:11) == 'KERNEL SET:') then
- substr=string(12:len_trim(string))
- ifst=1
- ilst=len_trim(substr)
- do while (substr(ifst:ifst) == ' '.and.ifst < ilst)
- ifst=ifst+1
- enddo
- if(ilst-ifst <= 0) then
- stop 'error reading model 2'
- else
- kernstri=substr(ifst:ilst)
- endif
- else if(string(1:25) == 'RADIAL STRUCTURE KERNELS:') then
- substr=string(26:len_trim(string))
- read(substr,*,iostat=ierror) nmodkern
- if(ierror /= 0) then
- stop 'error reading model 3'
- endif
- else if(string(1:4) == 'DESC'.and.string(9:9) == ':') then
- read(string(5:8),"(i4)") idummy
- substr=string(10:len_trim(string))
- ifst=1
- ilst=len_trim(substr)
- do while (substr(ifst:ifst) == ' '.and.ifst < ilst)
- ifst=ifst+1
- enddo
- if(ilst-ifst <= 0) then
- stop 'error reading model 4'
- else
- desckern(idummy)=substr(ifst:ilst)
- endif
- else if(string(1:29) == 'HORIZONTAL PARAMETERIZATIONS:') then
- substr=string(30:len_trim(string))
- read(substr,*,iostat=ierror) nhorpar
- if(ierror /= 0) then
- stop 'error reading model 5'
- endif
- else if(string(1:4) == 'HPAR'.and.string(9:9) == ':') then
- read(string(5:8),"(i4)") idummy
- ifst=10
- ilst=len_trim(string)
- do while (string(ifst:ifst) == ' '.and.ifst < ilst)
- ifst=ifst+1
- enddo
- if(ilst-ifst <= 0) then
- stop 'error reading model 6'
- else if(string(ifst:ifst+19) == 'SPHERICAL HARMONICS,') then
- substr=string(20+ifst:len_trim(string))
- read(substr,*) lmax
- ityphpar(idummy)=1
- lmaxhor(idummy)=lmax
- ncoefhor(idummy)=(lmax+1)**2
- else if(string(ifst:ifst+17) == 'SPHERICAL SPLINES,') then
- ifst1=ifst+18
- ifst=len_trim(string)
- ilst=len_trim(string)
- do while(string(ifst:ifst) /= ',')
- ifst=ifst-1
- enddo
- read(string(ifst+1:ilst),*) ncoef
- substr=string(ifst1:ifst-1)
- do while (string(ifst1:ifst1) == ' '.and.ifst1 < ifst)
- ifst1=ifst1+1
- enddo
- hsplfile(idummy)=string(ifst1:ifst-1)
- ityphpar(idummy)=2
- lmaxhor(idummy)=0
- ncoefhor(idummy)=ncoef
- do i=1,ncoef
- read(lu,*) ixlspl(i,idummy),xlaspl(i,idummy), &
- xlospl(i,idummy),xraspl(i,idummy)
- enddo
- endif
- else if(string(1:4) == 'STRU'.and.string(9:9) == ':') then
- read(string(5:8),"(i4)") idummy
- substr=string(10:len_trim(string))
- read(substr,*) ihor
- ihorpar(idummy)=ihor
- ncoef=ncoefhor(ihor)
- read(lu,"(6e12.4)") (coef(i,idummy),i=1,ncoef)
- endif
- endif
- enddo
- close(lu)
-
- end subroutine rd3dmodl
-
-
- subroutine 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)
-
- implicit none
-
- integer THREE_D_MODEL,THREE_D_MODEL_S362ANI
- integer THREE_D_MODEL_S362WMANI
- integer THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA
-
- integer lu
- character(len=128) modeldef
- logical exists
- integer numvar
- integer ierror
-
- integer, parameter :: maxker=200
- integer, parameter :: maxl=72
- integer, parameter :: maxcoe=2000
- integer, parameter :: maxver=1000
- integer, parameter :: maxhpa=2
-
- integer numker
- integer numhpa
- integer ihpa
- integer lmxhpa(maxhpa)
- integer itypehpa(maxhpa)
- integer ihpakern(maxker)
- integer numcoe(maxhpa)
- integer ivarkern(maxker)
- integer itpspl(maxcoe,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)
-
- character(len=80) kerstr
- character(len=80) refmdl
- character(len=40) varstr(maxker)
-
-! -------------------------------------
-
- lu=1 ! --- log unit: input 3-D model
- if(THREE_D_MODEL == THREE_D_MODEL_S362ANI) then
- modeldef='DATA/s362ani/S362ANI'
- elseif(THREE_D_MODEL == THREE_D_MODEL_S362WMANI) then
- modeldef='DATA/s362ani/S362WMANI'
- elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM) then
- modeldef='DATA/s362ani/S362ANI_PREM'
- elseif(THREE_D_MODEL == THREE_D_MODEL_S29EA) then
- modeldef='DATA/s362ani/S2.9EA'
- else
- stop 'unknown 3D model in read_model_s362ani'
- endif
- inquire(file=modeldef,exist=exists)
- if(exists) then
- call gt3dmodl(lu,modeldef, &
- maxhpa,maxker,maxcoe, &
- numhpa,numker,numcoe,lmxhpa, &
- ihpakern,itypehpa,coe, &
- itpspl,xlaspl,xlospl,radspl, &
- numvar,ivarkern,varstr, &
- refmdl,kerstr,hsplfl,dskker,ierror)
- else
- write(6,"('the model ',a,' does not exits')") modeldef(1:len_trim(modeldef))
- endif
-
-! --- check arrays
-
- if(numker > maxker) stop 'numker > maxker'
- do ihpa=1,numhpa
- if(itypehpa(ihpa) == 1) then
- if(lmxhpa(ihpa) > maxl) stop 'lmxhpa(ihpa) > maxl'
- else if(itypehpa(ihpa) == 2) then
- if(numcoe(ihpa) > maxcoe) stop 'numcoe(ihpa) > maxcoe'
- else
- stop 'problem with itypehpa'
- endif
- enddo
-
- end subroutine read_model_s362ani
-
-
- subroutine splcon(xlat,xlon,nver,verlat,verlon,verrad,ncon,icon,con)
-
- implicit none
-
- integer icon(1)
-
- real(kind=4) verlat(1)
- real(kind=4) verlon(1)
- real(kind=4) verrad(1)
- real(kind=4) con(1)
-
- double precision dd
- double precision rn
- double precision dr
- double precision xrad
- double precision ver8
- double precision xla8
-
- integer :: ncon,iver,nver
-
- real(kind=4) :: xlat,xlon
-
- xrad=3.14159265358979/180.d0
-
- ncon=0
-
- do iver=1,nver
- if(xlat > verlat(iver)-2.*verrad(iver)) then
- if(xlat < verlat(iver)+2.*verrad(iver)) then
- ver8=xrad*(verlat(iver))
- xla8=xrad*(xlat)
- dd=sin(ver8)*sin(xla8)
- dd=dd+cos(ver8)*cos(xla8)* cos(xrad*(xlon-verlon(iver)))
- dd=acos(dd)/xrad
- if(dd > (verrad(iver))*2.d0) then
- else
- ncon=ncon+1
- icon(ncon)=iver
- rn=dd/(verrad(iver))
- dr=rn-1.d0
- if(rn <= 1.d0) then
- con(ncon)=(0.75d0*rn-1.5d0)*(rn**2)+1.d0
- else if(rn > 1.d0) then
- con(ncon)=((-0.25d0*dr+0.75d0)*dr-0.75d0)*dr+0.25d0
- else
- con(ncon)=0.
- endif
- endif
- endif
- endif
- enddo
-
- end subroutine splcon
-
-
-! --- evaluate perturbations in per cent
-
- subroutine subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
- 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)
-
- implicit none
-
- 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)
-
- real(kind=4) :: xcolat,xlon,xrad
- real(kind=4) :: dvsh,dvsv,dvph,dvpv
-
-! --- model evaluation
-
- integer ish ! --- 0 if SV, 1 if SH
- integer ieval ! --- 1 for velocity, 2 for anisotropy
- real(kind=4) :: valu(2) ! --- valu(1) if S; valu(1)=velo, valu(2)=aniso
- real(kind=4) :: value ! --- used in single evaluation of perturbation
- integer isel ! --- if variable should be included
- real(kind=4) :: depth ! --- depth
- real(kind=4) :: x,y ! --- lat lon
- real(kind=4) :: vsh3drel ! --- relative perturbation
- real(kind=4) :: vsv3drel ! --- relative perturbation
-
-! ---
-
- integer iker,i
- character(len=40) vstr
- integer lstr
- integer ierror
-
-! -------------------------------------
-
- depth=6371.0-xrad
- call evradker (depth,kerstr,numker,vercof,vercofd,ierror)
- if(ierror /= 0) stop 'ierror evradker'
-
-! --- loop over sv and sh (sv=0,sh=1)
-
- do ish=0,1
-
-! --- contributing horizontal basis functions at xlat,xlon
-
- y=90.0-xcolat
- x=xlon
- do ihpa=1,numhpa
- if(itypehpa(ihpa) == 1) then
- lmax=lmxhpa(ihpa)
- call ylm(y,x,lmax,ylmcof(1,ihpa),wk1,wk2,wk3)
- else if(itypehpa(ihpa) == 2) then
- numcof=numcoe(ihpa)
- call splcon(y,x,numcof,xlaspl(1,ihpa), &
- xlospl(1,ihpa),radspl(1,ihpa), &
- nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
- else
- write(6,"('problem 1')")
- endif
- enddo
-
-! --- evaluate 3-D perturbations in velocity and anisotropy
-
- valu(1)=0. ! --- velocity
- valu(2)=0. ! --- anisotropy
-
- do ieval=1,2
- value=0.
- do iker=1,numker
- isel=0
- lstr=len_trim(varstr(ivarkern(iker)))
- vstr=(varstr(ivarkern(iker)))
- if(ieval == 1) then
- if(vstr(1:lstr) == 'UM (SH+SV)*0.5,'.or. &
- vstr(1:lstr) == 'LM (SH+SV)*0.5,'.or. &
- vstr(1:lstr) == 'EA (SH+SV)*0.5,') then
- isel=1
- endif
- else if(ieval == 2) then
- if(vstr(1:lstr) == 'UM SH-SV,'.or. &
- vstr(1:lstr) == 'LM SH-SV,'.or. &
- vstr(1:lstr) == 'EA SH-SV,') then
- isel=1
- endif
- endif
-
- if(isel == 1) then
- if(vercof(iker) /= 0.) then
- if(itypehpa(ihpakern(iker)) == 1) then
- ihpa=ihpakern(iker)
- nylm=(lmxhpa(ihpakern(iker))+1)**2
- do i=1,nylm
- value=value+vercof(iker)*ylmcof(i,ihpa) &
- *coe(i,iker)
- enddo
- else if(itypehpa(ihpakern(iker)) == 2) then
- ihpa=ihpakern(iker)
- do i=1,nconpt(ihpa)
- iver=iconpt(i,ihpa)
- value=value+vercof(iker)*conpt(i,ihpa) &
- *coe(iver,iker)
- enddo
- else
- write(6,"('problem 2')")
- stop
- endif ! --- itypehpa
- endif ! --- vercof(iker) /= 0.
- endif ! --- isel == 1
- enddo ! --- end of do iker=1,numker
-
- valu(ieval)=value
- enddo ! --- ieval
-
-! --- evaluate perturbations in vsh and vsv
-
- if(ish == 1) then
- vsh3drel=valu(1)+0.5*valu(2)
- else if(ish == 0) then
- vsv3drel=valu(1)-0.5*valu(2)
- else
- stop 'something wrong'
- endif
-
- enddo ! --- by ish
-
-! --- evaluate perturbations in per cent
-
- dvsh=vsh3drel
- dvsv=vsv3drel
- dvph=0.55*dvsh ! --- scaling used in the inversion
- dvpv=0.55*dvsv ! --- scaling used in the inversion
-
- end subroutine subshsv
-
-
-! --- evaluate depressions of the 410- and 650-km discontinuities in km
-
- subroutine subtopo(xcolat,xlon,topo410,topo650, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,ylmcof,wk1,wk2,wk3,varstr)
-
- implicit none
-
- 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) 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=40) varstr(maxker)
-
- real(kind=4) :: xcolat,xlon
- real(kind=4) :: topo410,topo650
-
-! --- model evaluation
-
- integer ieval ! --- 1 for velocity, 2 for anisotropy
- real(kind=4) :: valu(2) ! --- valu(1) if S; valu(1)=velo, valu(2)=aniso
- real(kind=4) :: value ! --- used in single evaluation of perturbation
- integer isel ! --- if variable should be included
- real(kind=4) :: x,y ! --- lat lon
-
-! ---
- integer iker,i
- character(len=40) vstr
- integer lstr
-
-! -------------------------------------
-
-! --- contributing horizontal basis functions at xlat,xlon
-
- y=90.0-xcolat
- x=xlon
- do ihpa=1,numhpa
- if(itypehpa(ihpa) == 1) then
- lmax=lmxhpa(ihpa)
- call ylm(y,x,lmax,ylmcof(1,ihpa),wk1,wk2,wk3)
- else if(itypehpa(ihpa) == 2) then
- numcof=numcoe(ihpa)
- call splcon(y,x,numcof,xlaspl(1,ihpa), &
- xlospl(1,ihpa),radspl(1,ihpa), &
- nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
- else
- write(6,"('problem 1')")
- endif
- enddo
-
-! --- evaluate topography (depression) in km
-
- valu(1)=0. ! --- 410
- valu(2)=0. ! --- 650
-
- do ieval=1,2
- value=0.
- do iker=1,numker
- isel=0
- lstr=len_trim(varstr(ivarkern(iker)))
- vstr=(varstr(ivarkern(iker)))
- if(ieval == 1) then
- if(vstr(1:lstr) == 'Topo 400,') then
- isel=1
- endif
- else if(ieval == 2) then
- if(vstr(1:lstr) == 'Topo 670,') then
- isel=1
- endif
- endif
-
- if(isel == 1) then
- if(itypehpa(ihpakern(iker)) == 1) then
- ihpa=ihpakern(iker)
- nylm=(lmxhpa(ihpakern(iker))+1)**2
- do i=1,nylm
- value=value+ylmcof(i,ihpa)*coe(i,iker)
- enddo
- else if(itypehpa(ihpakern(iker)) == 2) then
- ihpa=ihpakern(iker)
- do i=1,nconpt(ihpa)
- iver=iconpt(i,ihpa)
- value=value+conpt(i,ihpa)*coe(iver,iker)
- enddo
- else
- write(6,"('problem 2')")
- stop
- endif ! --- itypehpa
- endif ! --- isel == 1
- enddo ! --- end of do iker=1,numker
-
- valu(ieval)=value
- enddo ! --- ieval
-
- topo410=valu(1)
- topo650=valu(2)
-
- end subroutine subtopo
-
- subroutine vbspl(x,np,xarr,splcon,splcond)
-!
-!---- this subroutine returns the spline contributions at a particular value of x
-!
- implicit none
-
- integer :: np
-
- real(kind=4) :: xarr(np),x
- real(kind=4) :: splcon(np)
- real(kind=4) :: splcond(np)
-
- real(kind=4) :: r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13
- real(kind=4) :: r1d,r2d,r3d,r4d,r5d,r6d,r7d,r8d,r9d,r10d,r11d,r12d,r13d,val,vald
-
- real(kind=4) :: rr1,rr2,rr3,rr4,rr5,rr6,rr7,rr8,rr9,rr10,rr11,rr12
- real(kind=4) :: rr1d,rr2d,rr3d,rr4d,rr5d,rr6d,rr7d,rr8d,rr9d,rr10d,rr11d,rr12d
-
- integer :: iflag,interval,ik,ib
-
-!
-!---- iflag=1 ==>> second derivative is 0 at end points
-!---- iflag=0 ==>> first derivative is 0 at end points
-!
- iflag=1
-!
-!---- first, find out within which interval x falls
-!
- interval=0
- ik=1
- do while(interval == 0.and.ik < np)
- ik=ik+1
- if(x >= xarr(ik-1).and.x <= xarr(ik)) interval=ik-1
- enddo
- if(x > xarr(np)) then
- interval=np
- endif
-
- if(interval == 0) then
-! write(6,"('low value:',2f10.3)") x,xarr(1)
- else if(interval > 0.and.interval < np) then
-! write(6,"('bracket:',i5,3f10.3)") interval,xarr(interval),x,xarr(interval+1)
- else
-! write(6,"('high value:',2f10.3)") xarr(np),x
- endif
-
- do ib=1,np
- val=0.
- vald=0.
- if(ib == 1) then
-
- r1=(x-xarr(1))/(xarr(2)-xarr(1))
- r2=(xarr(3)-x)/(xarr(3)-xarr(1))
- r4=(xarr(2)-x)/(xarr(2)-xarr(1))
- r5=(x-xarr(1))/(xarr(2)-xarr(1))
- r6=(xarr(3)-x)/(xarr(3)-xarr(1))
- r10=(xarr(2)-x)/(xarr(2)-xarr(1))
- r11=(x-xarr(1)) /(xarr(2)-xarr(1))
- r12=(xarr(3)-x)/(xarr(3)-xarr(2))
- r13=(xarr(2)-x)/(xarr(2)-xarr(1))
-
- r1d=1./(xarr(2)-xarr(1))
- r2d=-1./(xarr(3)-xarr(1))
- r4d=-1./(xarr(2)-xarr(1))
- r5d=1./(xarr(2)-xarr(1))
- r6d=-1./(xarr(3)-xarr(1))
- r10d=-1./(xarr(2)-xarr(1))
- r11d=1./(xarr(2)-xarr(1))
- r12d=-1./(xarr(3)-xarr(2))
- r13d=-1./(xarr(2)-xarr(1))
-
- if(interval == ib.or.interval == 0) then
- if(iflag == 0) then
- val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11 +r13**3
- vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
- vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
- vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
- vald=vald+3.*r13d*r13**2
- else if(iflag == 1) then
- val=0.6667*(r1*r4*r10 + r2*r5*r10 + r2*r6*r11 &
- + 1.5*r13**3)
- vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
- vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
- vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
- vald=vald+4.5*r13d*r13**2
- vald=0.6667*vald
- endif
- else if(interval == ib+1) then
- if(iflag == 0) then
- val=r2*r6*r12
- vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
- else if(iflag == 1) then
- val=0.6667*r2*r6*r12
- vald=0.6667*(r2d*r6*r12+r2*r6d*r12+r2*r6*r12d)
- endif
- else
- val=0.
- endif
-
- else if(ib == 2) then
-
- rr1=(x-xarr(1))/(xarr(2)-xarr(1))
- rr2=(xarr(3)-x)/(xarr(3)-xarr(1))
- rr4=(xarr(2)-x)/(xarr(2)-xarr(1))
- rr5=(x-xarr(1))/(xarr(2)-xarr(1))
- rr6=(xarr(3)-x)/(xarr(3)-xarr(1))
- rr10=(xarr(2)-x)/(xarr(2)-xarr(1))
- rr11=(x-xarr(1)) /(xarr(2)-xarr(1))
- rr12=(xarr(3)-x)/(xarr(3)-xarr(2))
-
- rr1d=1./(xarr(2)-xarr(1))
- rr2d=-1./(xarr(3)-xarr(1))
- rr4d=-1./(xarr(2)-xarr(1))
- rr5d=1./(xarr(2)-xarr(1))
- rr6d=-1./(xarr(3)-xarr(1))
- rr10d=-1./(xarr(2)-xarr(1))
- rr11d=1./(xarr(2)-xarr(1))
- rr12d=-1./(xarr(3)-xarr(2))
-
- r1=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
- r2=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib-1))
- r3=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
- r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
- r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
- r6=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib))
- r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
- r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
- r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
- r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
- r12=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib+1))
-
- r1d=1./(xarr(ib+1)-xarr(ib-1))
- r2d=-1./(xarr(ib+2)-xarr(ib-1))
- r3d=1./(xarr(ib)-xarr(ib-1))
- r4d=-1./(xarr(ib+1)-xarr(ib-1))
- r5d=1./(xarr(ib+1)-xarr(ib-1))
- r6d=-1./(xarr(ib+2)-xarr(ib))
- r8d=-1./ (xarr(ib)-xarr(ib-1))
- r9d=1./(xarr(ib)-xarr(ib-1))
- r10d=-1./(xarr(ib+1)-xarr(ib))
- r11d=1./(xarr(ib+1)-xarr(ib))
- r12d=-1./(xarr(ib+2)-xarr(ib+1))
-
- if(interval == ib-1.or.interval == 0) then
- val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
- vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
- vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
- vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
- if(iflag == 1) then
- val=val+0.3333*(rr1*rr4*rr10 + rr2*rr5*rr10 + &
- rr2*rr6*rr11)
- vald=vald+0.3333*(rr1d*rr4*rr10+rr1*rr4d*rr10+ &
- rr1*rr4*rr10d)
- vald=vald+0.3333*(rr2d*rr5*rr10+rr2*rr5d*rr10+ &
- rr2*rr5*rr10d)
- vald=vald+0.3333*(rr2d*rr6*rr11+rr2*rr6d*rr11+ &
- rr2*rr6*rr11d)
- endif
- else if(interval == ib) then
- val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
- vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
- vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
- vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
- if(iflag == 1) then
- val=val+0.3333*rr2*rr6*rr12
- vald=vald+0.3333*(rr2d*rr6*rr12+rr2*rr6d*rr12+ &
- rr2*rr6*rr12d)
- endif
- else if(interval == ib+1) then
- val=r2*r6*r12
- vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
- else
- val=0.
- endif
- else if(ib == np-1) then
-
- rr1=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
- rr2=(xarr(np)-x)/(xarr(np)-xarr(np-1))
- rr3=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
- rr4=(xarr(np)-x)/(xarr(np)-xarr(np-1))
- rr5=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
- rr7=(x-xarr(np-2))/(xarr(np-1)-xarr(np-2))
- rr8=(xarr(np)-x)/ (xarr(np)-xarr(np-1))
- rr9=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-
- rr1d=1./(xarr(np)-xarr(np-2))
- rr2d=-1./(xarr(np)-xarr(np-1))
- rr3d=1./(xarr(np)-xarr(np-2))
- rr4d=-1./(xarr(np)-xarr(np-1))
- rr5d=1./(xarr(np)-xarr(np-1))
- rr7d=1./(xarr(np-1)-xarr(np-2))
- rr8d=-1./ (xarr(np)-xarr(np-1))
- rr9d=1./(xarr(np)-xarr(np-1))
-
- r1=(x-xarr(ib-2))/(xarr(ib+1)-xarr(ib-2))
- r2=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
- r3=(x-xarr(ib-2))/(xarr(ib)-xarr(ib-2))
- r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
- r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
- r6=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
- r7=(x-xarr(ib-2))/(xarr(ib-1)-xarr(ib-2))
- r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
- r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
- r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
- r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
-
- r1d=1./(xarr(ib+1)-xarr(ib-2))
- r2d=-1./(xarr(ib+1)-xarr(ib-1))
- r3d=1./(xarr(ib)-xarr(ib-2))
- r4d=-1./(xarr(ib+1)-xarr(ib-1))
- r5d=1./(xarr(ib+1)-xarr(ib-1))
- r6d=-1./(xarr(ib+1)-xarr(ib))
- r7d=1./(xarr(ib-1)-xarr(ib-2))
- r8d=-1./(xarr(ib)-xarr(ib-1))
- r9d=1./(xarr(ib)-xarr(ib-1))
- r10d=-1./(xarr(ib+1)-xarr(ib))
- r11d=1./(xarr(ib+1)-xarr(ib))
-
- if(interval == ib-2) then
- val=r1*r3*r7
- vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
- else if(interval == ib-1) then
- val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
- vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
- vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
- vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
- if(iflag == 1) then
- val=val+0.3333*rr1*rr3*rr7
- vald=vald+0.3333*(rr1d*rr3*rr7+rr1*rr3d*rr7+ &
- rr1*rr3*rr7d)
- endif
- else if(interval == ib.or.interval == np) then
- val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
- vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
- vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
- vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
- if(iflag == 1) then
- val=val+0.3333*(rr1*rr3*rr8 + rr1*rr4*rr9 + &
- rr2*rr5*rr9)
- vald=vald+0.3333*(rr1d*rr3*rr8+rr1*rr3d*rr8+ &
- rr1*rr3*rr8d)
- vald=vald+0.3333*(rr1d*rr4*rr9+rr1*rr4d*rr9+ &
- rr1*rr4*rr9d)
- vald=vald+0.3333*(rr2d*rr5*rr9+rr2*rr5d*rr9+ &
- rr2*rr5*rr9d)
- endif
- else
- val=0.
- endif
- else if(ib == np) then
-
- r1=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
- r2=(xarr(np)-x)/(xarr(np)-xarr(np-1))
- r3=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
- r4=(xarr(np)-x)/(xarr(np)-xarr(np-1))
- r5=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
- r7=(x-xarr(np-2))/(xarr(np-1)-xarr(np-2))
- r8=(xarr(np)-x)/ (xarr(np)-xarr(np-1))
- r9=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
- r13=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-
- r1d=1./(xarr(np)-xarr(np-2))
- r2d=-1./(xarr(np)-xarr(np-1))
- r3d=1./(xarr(np)-xarr(np-2))
- r4d=-1./(xarr(np)-xarr(np-1))
- r5d=1./(xarr(np)-xarr(np-1))
- r7d=1./(xarr(np-1)-xarr(np-2))
- r8d=-1./ (xarr(np)-xarr(np-1))
- r9d=1./(xarr(np)-xarr(np-1))
- r13d=1./(xarr(np)-xarr(np-1))
-
- if(interval == np-2) then
- if(iflag == 0) then
- val=r1*r3*r7
- vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
- else if(iflag == 1) then
- val=0.6667*r1*r3*r7
- vald=0.6667*(r1d*r3*r7+r1*r3d*r7+r1*r3*r7d)
- endif
- else if(interval == np-1.or.interval == np) then
- if(iflag == 0) then
- val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + r13**3
- vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
- vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
- vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
- vald=vald+3.*r13d*r13**2
- else if(iflag == 1) then
- val=0.6667*(r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + &
- 1.5*r13**3)
- vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
- vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
- vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
- vald=vald+4.5*r13d*r13**2
- vald=0.6667*vald
- endif
- else
- val=0.
- endif
- else
-
- r1=(x-xarr(ib-2))/(xarr(ib+1)-xarr(ib-2))
- r2=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib-1))
- r3=(x-xarr(ib-2))/(xarr(ib)-xarr(ib-2))
- r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
- r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
- r6=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib))
- r7=(x-xarr(ib-2))/(xarr(ib-1)-xarr(ib-2))
- r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
- r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
- r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
- r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
- r12=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib+1))
-
- r1d=1./(xarr(ib+1)-xarr(ib-2))
- r2d=-1./(xarr(ib+2)-xarr(ib-1))
- r3d=1./(xarr(ib)-xarr(ib-2))
- r4d=-1./(xarr(ib+1)-xarr(ib-1))
- r5d=1./(xarr(ib+1)-xarr(ib-1))
- r6d=-1./(xarr(ib+2)-xarr(ib))
- r7d=1./(xarr(ib-1)-xarr(ib-2))
- r8d=-1./ (xarr(ib)-xarr(ib-1))
- r9d=1./(xarr(ib)-xarr(ib-1))
- r10d=-1./(xarr(ib+1)-xarr(ib))
- r11d=1./(xarr(ib+1)-xarr(ib))
- r12d=-1./(xarr(ib+2)-xarr(ib+1))
-
- if(interval == ib-2) then
- val=r1*r3*r7
- vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
- else if(interval == ib-1) then
- val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
- vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
- vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
- vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
- else if(interval == ib) then
- val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
- vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
- vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
- vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
- else if(interval == ib+1) then
- val=r2*r6*r12
- vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
- else
- val=0.
- endif
- endif
- splcon(ib)=val
- splcond(ib)=vald
- enddo
-
- end subroutine vbspl
-
-
- subroutine ylm(XLAT,XLON,LMAX,Y,WK1,WK2,WK3)
-
- implicit none
-
- complex TEMP,FAC,DFAC
-
- real(kind=4) WK1(1),WK2(1),WK3(1),Y(1),XLAT,XLON
-
- integer :: LMAX
-
-!
-! WK1,WK2,WK3 SHOULD BE DIMENSIONED AT LEAST (LMAX+1)*4
-!
- real(kind=4), parameter :: RADIAN = 57.2957795
-
- integer :: IM,IL1,IND,LM1,L
-
- real(kind=4) :: THETA,PHI
-
- THETA=(90.-XLAT)/RADIAN
- PHI=XLON/RADIAN
-
- IND=0
- LM1=LMAX+1
-
- DO IL1=1,LM1
-
- L=IL1-1
- CALL legndr(THETA,L,L,WK1,WK2,WK3)
-
- FAC=(1.,0.)
- DFAC=CEXP(CMPLX(0.,PHI))
-
- do IM=1,IL1
- TEMP=FAC*CMPLX(WK1(IM),0.)
- IND=IND+1
- Y(IND)=REAL(TEMP)
- IF(IM == 1) GOTO 20
- IND=IND+1
- Y(IND)=AIMAG(TEMP)
- 20 FAC=FAC*DFAC
- enddo
-
- enddo
-
- end subroutine ylm
-
-!------------------------------------
-
- subroutine legndr(THETA,L,M,X,XP,XCOSEC)
-
- implicit none
-
- real(kind=4) :: X(2),XP(2),XCOSEC(2)
-
- double precision :: SMALL,SUM,COMPAR,CT,ST,FCT,COT,X1,X2,X3,F1,F2,XM,TH
-
- double precision, parameter :: FPI = 12.56637062D0
-
- integer :: i,M,MP1,k,l,LP1
-
- real(kind=4) :: THETA,DSFL3,COSEC,SFL3
-
-!!!!!! illegal statement, removed by Dimitri Komatitsch DFLOAT(I)=FLOAT(I)
-
- SUM=0.D0
- LP1=L+1
- TH=THETA
- CT=DCOS(TH)
- ST=DSIN(TH)
- MP1=M+1
- FCT=DSQRT(dble(2*L+1)/FPI)
- SFL3=SQRT(FLOAT(L*(L+1)))
- COMPAR=dble(2*L+1)/FPI
- DSFL3=SFL3
- SMALL=1.D-16*COMPAR
-
- do I=1,MP1
- X(I)=0.
- XCOSEC(I)=0.
- XP(I)=0.
- enddo
-
- IF(L > 1.AND.ABS(THETA) > 1.E-5) GO TO 3
- X(1)=FCT
- IF(L == 0) RETURN
- X(1)=CT*FCT
- X(2)=-ST*FCT/DSFL3
- XP(1)=-ST*FCT
- XP(2)=-.5D0*CT*FCT*DSFL3
- IF(ABS(THETA) < 1.E-5) XCOSEC(2)=XP(2)
- IF(ABS(THETA) >= 1.E-5) XCOSEC(2)=X(2)/ST
- RETURN
-
- 3 X1=1.D0
- X2=CT
-
- do I=2,L
- X3=(dble(2*I-1)*CT*X2-dble(I-1)*X1)/dble(I)
- X1=X2
- X2=X3
- enddo
-
- COT=CT/ST
- COSEC=1./ST
- X3=X2*FCT
- X2=dble(L)*(X1-CT*X2)*FCT/ST
- X(1)=X3
- X(2)=X2
- SUM=X3*X3
- XP(1)=-X2
- XP(2)=dble(L*(L+1))*X3-COT*X2
- X(2)=-X(2)/SFL3
- XCOSEC(2)=X(2)*COSEC
- XP(2)=-XP(2)/SFL3
- SUM=SUM+2.D0*X(2)*X(2)
- IF(SUM-COMPAR > SMALL) RETURN
- X1=X3
- X2=-X2/DSQRT(dble(L*(L+1)))
-
- do I=3,MP1
- K=I-1
- F1=DSQRT(dble((L+I-1)*(L-I+2)))
- F2=DSQRT(dble((L+I-2)*(L-I+3)))
- XM=K
- X3=-(2.D0*COT*(XM-1.D0)*X2+F2*X1)/F1
- SUM=SUM+2.D0*X3*X3
- IF(SUM-COMPAR > SMALL.AND.I /= LP1) RETURN
- X(I)=X3
- XCOSEC(I)=X(I)*COSEC
- X1=X2
- XP(I)=-(F1*X2+XM*COT*X3)
- X2=X3
- enddo
-
- end subroutine legndr
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/save_header_file.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/save_header_file.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,490 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! save header file OUTPUT_FILES/values_from_mesher.h
-
- subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
- INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP,&
- static_memory_size,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
- NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
- NPROC_XI,NPROC_ETA, &
- NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
-
- implicit none
-
- include "constants.h"
-
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC, nglob
-
- integer NEX_XI,NEX_ETA,NPROC,NPROCTOT,NCHUNKS,NSOURCES,NSTEP
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D,INCLUDE_CENTRAL_CUBE
-
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
- CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH
-
- double precision :: subtract_central_cube_elems,subtract_central_cube_points
-
- character(len=150) HEADER_FILE
-
-! for regional code
- double precision x,y,gamma,rgt,xi,eta
- double precision x_top,y_top,z_top
- double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
-
-! rotation matrix from Euler angles
- integer i,j,ix,iy,icorner
- double precision rotation_matrix(3,3)
- double precision vector_ori(3),vector_rotated(3)
- double precision r_corner,theta_corner,phi_corner,lat,long,colat_corner
-
-! static memory size needed by the solver
- double precision :: static_memory_size
-
- integer :: att1,att2,att3,att4,att5,NCORNERSCHUNKS,NUM_FACES,NUM_MSG_TYPES
-
- integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NSPEC2D_TOP,NSPEC2D_BOTTOM,NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX
- integer :: NPROC_XI,NPROC_ETA
-
- integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION, &
- NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670, NSPEC2D_CMB, NSPEC2D_ICB
-
-! copy number of elements and points in an include file for the solver
- call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
- open(unit=IOUT,file=HEADER_FILE,status='unknown')
- write(IOUT,*)
-
- write(IOUT,*) '!'
- write(IOUT,*) '! this is the parameter file for static compilation of the solver'
- write(IOUT,*) '!'
- write(IOUT,*) '! mesh statistics:'
- write(IOUT,*) '! ---------------'
- write(IOUT,*) '!'
- write(IOUT,*) '!'
- write(IOUT,*) '! number of chunks = ',NCHUNKS
- write(IOUT,*) '!'
-
-! the central cube is counted 6 times, therefore remove 5 times
- if(INCLUDE_CENTRAL_CUBE) then
- write(IOUT,*) '! these statistics include the central cube'
- subtract_central_cube_elems = 5.d0 * dble((NEX_XI/8))**3
- subtract_central_cube_points = 5.d0 * (dble(NEX_XI/8)*dble(NGLLX-1)+1.d0)**3
- else
- write(IOUT,*) '! these statistics do not include the central cube'
- subtract_central_cube_elems = 0.d0
- subtract_central_cube_points = 0.d0
- endif
-
- write(IOUT,*) '!'
- write(IOUT,*) '! number of processors = ',NPROCTOT
- write(IOUT,*) '!'
- write(IOUT,*) '! maximum number of points per region = ',nglob(IREGION_CRUST_MANTLE)
- write(IOUT,*) '!'
-! use fused loops on NEC SX
- write(IOUT,*) '! on NEC SX, make sure "loopcnt=" parameter'
- write(IOUT,*) '! in Makefile is greater than max vector length = ',nglob(IREGION_CRUST_MANTLE)*NDIM
- write(IOUT,*) '!'
-
- write(IOUT,*) '! total elements per slice = ',sum(NSPEC)
- write(IOUT,*) '! total points per slice = ',sum(nglob)
- write(IOUT,*) '!'
-
- write(IOUT,*) '! total for full 6-chunk mesh:'
- write(IOUT,*) '! ---------------------------'
- write(IOUT,*) '!'
- write(IOUT,*) '! exact total number of spectral elements in entire mesh = '
- write(IOUT,*) '! ',6.d0*dble(NPROC)*dble(sum(NSPEC)) - subtract_central_cube_elems
- write(IOUT,*) '! approximate total number of points in entire mesh = '
- write(IOUT,*) '! ',2.d0*dble(NPROC)*(3.d0*dble(sum(nglob))) - subtract_central_cube_points
-! there are 3 DOFs in solid regions, but only 1 in fluid outer core
- write(IOUT,*) '! approximate total number of degrees of freedom in entire mesh = '
- write(IOUT,*) '! ',6.d0*dble(NPROC)*(3.d0*(dble(sum(nglob))) &
- - 2.d0*dble(nglob(IREGION_OUTER_CORE))) &
- - 3.d0*subtract_central_cube_points
- write(IOUT,*) '!'
-
-! display location of chunk if regional run
- if(NCHUNKS /= 6) then
-
- write(IOUT,*) '! position of the mesh chunk at the surface:'
- write(IOUT,*) '! -----------------------------------------'
- write(IOUT,*) '!'
- write(IOUT,*) '! angular size in first direction in degrees = ',sngl(ANGULAR_WIDTH_XI_IN_DEGREES)
- write(IOUT,*) '! angular size in second direction in degrees = ',sngl(ANGULAR_WIDTH_ETA_IN_DEGREES)
- write(IOUT,*) '!'
- write(IOUT,*) '! longitude of center in degrees = ',sngl(CENTER_LONGITUDE_IN_DEGREES)
- write(IOUT,*) '! latitude of center in degrees = ',sngl(CENTER_LATITUDE_IN_DEGREES)
- write(IOUT,*) '!'
- write(IOUT,*) '! angle of rotation of the first chunk = ',sngl(GAMMA_ROTATION_AZIMUTH)
-
-! convert width to radians
- ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * DEGREES_TO_RADIANS
- ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * DEGREES_TO_RADIANS
-
-! compute rotation matrix from Euler angles
- call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
-
-! loop on the four corners of the chunk to display their coordinates
- icorner = 0
- do iy = 0,1
- do ix = 0,1
-
- icorner = icorner + 1
-
- xi= - ANGULAR_WIDTH_XI_RAD/2. + dble(ix)*ANGULAR_WIDTH_XI_RAD
- eta= - ANGULAR_WIDTH_ETA_RAD/2. + dble(iy)*ANGULAR_WIDTH_ETA_RAD
-
- x=dtan(xi)
- y=dtan(eta)
-
- gamma=ONE/dsqrt(ONE+x*x+y*y)
- rgt=R_UNIT_SPHERE*gamma
-
-! define the mesh points at the top surface
- x_top=-y*rgt
- y_top=x*rgt
- z_top=rgt
-
-! rotate top
- vector_ori(1) = x_top
- vector_ori(2) = y_top
- vector_ori(3) = z_top
- do i=1,3
- vector_rotated(i)=0.0d0
- do j=1,3
- vector_rotated(i)=vector_rotated(i)+rotation_matrix(i,j)*vector_ori(j)
- enddo
- enddo
- x_top = vector_rotated(1)
- y_top = vector_rotated(2)
- z_top = vector_rotated(3)
-
-! convert to latitude and longitude
- call xyz_2_rthetaphi_dble(x_top,y_top,z_top,r_corner,theta_corner,phi_corner)
- call reduce(theta_corner,phi_corner)
-
-! convert geocentric to geographic colatitude
- colat_corner=PI/2.0d0-datan(1.006760466d0*dcos(theta_corner)/dmax1(TINYVAL,dsin(theta_corner)))
- if(phi_corner>PI) phi_corner=phi_corner-TWO_PI
-
-! compute real position of the source
- lat = (PI/2.0d0-colat_corner)*180.0d0/PI
- long = phi_corner*180.0d0/PI
-
- write(IOUT,*) '!'
- write(IOUT,*) '! corner ',icorner
- write(IOUT,*) '! longitude in degrees = ',long
- write(IOUT,*) '! latitude in degrees = ',lat
-
- enddo
- enddo
-
- write(IOUT,*) '!'
-
- endif ! regional chunk
-
- write(IOUT,*) '! resolution of the mesh at the surface:'
- write(IOUT,*) '! -------------------------------------'
- write(IOUT,*) '!'
- write(IOUT,*) '! spectral elements along a great circle = ',4*NEX_XI
- write(IOUT,*) '! GLL points along a great circle = ',4*NEX_XI*(NGLLX-1)
- write(IOUT,*) '! average distance between points in degrees = ',360./real(4*NEX_XI*(NGLLX-1))
- write(IOUT,*) '! average distance between points in km = ',real(TWO_PI*R_EARTH/1000.d0)/real(4*NEX_XI*(NGLLX-1))
- write(IOUT,*) '! average size of a spectral element in km = ',real(TWO_PI*R_EARTH/1000.d0)/real(4*NEX_XI)
- write(IOUT,*) '!'
- write(IOUT,*) '! number of time steps = ',NSTEP
- write(IOUT,*) '!'
- write(IOUT,*) '! number of seismic sources = ',NSOURCES
- write(IOUT,*) '!'
- write(IOUT,*)
-
- write(IOUT,*) '! approximate static memory needed by the solver:'
- write(IOUT,*) '! ----------------------------------------------'
- write(IOUT,*) '!'
- write(IOUT,*) '! size of static arrays per slice = ',static_memory_size/1073741824.d0,' GB'
- write(IOUT,*) '!'
- write(IOUT,*) '! (should be below and typically equal to 80% of 1.5 GB = 1.2 GB on pangu'
- write(IOUT,*) '! at Caltech, and below and typically equal to 85% of 2 GB = 1.7 GB'
- write(IOUT,*) '! on Marenostrum in Barcelona)'
- write(IOUT,*) '! (if significantly more, the job will not run by lack of memory)'
- write(IOUT,*) '! (if significantly less, you waste a significant amount of memory)'
- write(IOUT,*) '!'
- write(IOUT,*) '! size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GB'
- write(IOUT,*) '! = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TB'
- write(IOUT,*) '!'
-
- write(IOUT,*)
- write(IOUT,*) 'integer, parameter :: NEX_XI_VAL = ',NEX_XI
- write(IOUT,*) 'integer, parameter :: NEX_ETA_VAL = ',NEX_ETA
- write(IOUT,*)
- write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE = ',NSPEC(IREGION_CRUST_MANTLE)
- write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE = ',NSPEC(IREGION_OUTER_CORE)
- write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE = ',NSPEC(IREGION_INNER_CORE)
- write(IOUT,*)
- write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE = ',nglob(IREGION_CRUST_MANTLE)
- write(IOUT,*) 'integer, parameter :: NGLOB_OUTER_CORE = ',nglob(IREGION_OUTER_CORE)
- write(IOUT,*) 'integer, parameter :: NGLOB_INNER_CORE = ',nglob(IREGION_INNER_CORE)
- write(IOUT,*)
-
- write(IOUT,*) 'integer, parameter :: NSPECMAX_ANISO_IC = ',NSPECMAX_ANISO_IC
- write(IOUT,*)
-
- write(IOUT,*) 'integer, parameter :: NSPECMAX_ISO_MANTLE = ',NSPECMAX_ISO_MANTLE
- write(IOUT,*) 'integer, parameter :: NSPECMAX_TISO_MANTLE = ',NSPECMAX_TISO_MANTLE
- write(IOUT,*) 'integer, parameter :: NSPECMAX_ANISO_MANTLE = ',NSPECMAX_ANISO_MANTLE
- write(IOUT,*)
-
- write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_ATTENUAT = ',NSPEC_CRUST_MANTLE_ATTENUAT
- write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_ATTENUATION = ',NSPEC_INNER_CORE_ATTENUATION
- write(IOUT,*)
-
- write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STR_OR_ATT = ',NSPEC_CRUST_MANTLE_STR_OR_ATT
- write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STR_OR_ATT = ',NSPEC_INNER_CORE_STR_OR_ATT
- write(IOUT,*)
-
- write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STR_AND_ATT = ',NSPEC_CRUST_MANTLE_STR_AND_ATT
- write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STR_AND_ATT = ',NSPEC_INNER_CORE_STR_AND_ATT
- write(IOUT,*)
-
- write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STRAIN_ONLY = ',NSPEC_CRUST_MANTLE_STRAIN_ONLY
- write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STRAIN_ONLY = ',NSPEC_INNER_CORE_STRAIN_ONLY
- write(IOUT,*)
-
- write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_ADJOINT = ',NSPEC_CRUST_MANTLE_ADJOINT
- write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ADJOINT = ',NSPEC_OUTER_CORE_ADJOINT
- write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_ADJOINT = ',NSPEC_INNER_CORE_ADJOINT
-
- write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE_ADJOINT = ',NGLOB_CRUST_MANTLE_ADJOINT
- write(IOUT,*) 'integer, parameter :: NGLOB_OUTER_CORE_ADJOINT = ',NGLOB_OUTER_CORE_ADJOINT
- write(IOUT,*) 'integer, parameter :: NGLOB_INNER_CORE_ADJOINT = ',NGLOB_INNER_CORE_ADJOINT
-
- write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ROT_ADJOINT = ',NSPEC_OUTER_CORE_ROT_ADJOINT
- write(IOUT,*)
-
- write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STACEY = ',NSPEC_CRUST_MANTLE_STACEY
- write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_STACEY = ',NSPEC_OUTER_CORE_STACEY
- write(IOUT,*)
-
- write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE_OCEANS = ',NGLOB_CRUST_MANTLE_OCEANS
- write(IOUT,*)
-
-! this to allow for code elimination by compiler in solver for performance
-
- if(TRANSVERSE_ISOTROPY) then
- write(IOUT,*) 'logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .true.'
- else
- write(IOUT,*) 'logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .false.'
- endif
- write(IOUT,*)
-
- if(ANISOTROPIC_3D_MANTLE) then
- write(IOUT,*) 'logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .true.'
- else
- write(IOUT,*) 'logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .false.'
- endif
- write(IOUT,*)
-
- if(ANISOTROPIC_INNER_CORE) then
- write(IOUT,*) 'logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .true.'
- else
- write(IOUT,*) 'logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .false.'
- endif
- write(IOUT,*)
-
- if(ATTENUATION) then
- write(IOUT,*) 'logical, parameter :: ATTENUATION_VAL = .true.'
- else
- write(IOUT,*) 'logical, parameter :: ATTENUATION_VAL = .false.'
- endif
- write(IOUT,*)
-
- if(ATTENUATION_3D) then
- write(IOUT,*) 'logical, parameter :: ATTENUATION_3D_VAL = .true.'
- else
- write(IOUT,*) 'logical, parameter :: ATTENUATION_3D_VAL = .false.'
- endif
- write(IOUT,*)
-
- if(ELLIPTICITY) then
- write(IOUT,*) 'logical, parameter :: ELLIPTICITY_VAL = .true.'
- else
- write(IOUT,*) 'logical, parameter :: ELLIPTICITY_VAL = .false.'
- endif
- write(IOUT,*)
-
- if(GRAVITY) then
- write(IOUT,*) 'logical, parameter :: GRAVITY_VAL = .true.'
- else
- write(IOUT,*) 'logical, parameter :: GRAVITY_VAL = .false.'
- endif
- write(IOUT,*)
-
- if(ROTATION) then
- write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .true.'
- else
- write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .false.'
- endif
- write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ROTATION = ',NSPEC_OUTER_CORE_ROTATION
- write(IOUT,*)
-
- write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_CM = ',NGLOB1D_RADIAL(IREGION_CRUST_MANTLE)
- write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_OC = ',NGLOB1D_RADIAL(IREGION_OUTER_CORE)
- write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_IC = ',NGLOB1D_RADIAL(IREGION_INNER_CORE)
-
- write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_CM = ',NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE)
- write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_OC = ',NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE)
- write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_IC = ',NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE)
-
- write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_CM = ',NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE)
- write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_OC = ',NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE)
- write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_IC = ',NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE)
-
- write(IOUT,*) 'integer, parameter :: NPROC_XI_VAL = ',NPROC_XI
- write(IOUT,*) 'integer, parameter :: NPROC_ETA_VAL = ',NPROC_ETA
- write(IOUT,*) 'integer, parameter :: NCHUNKS_VAL = ',NCHUNKS
- write(IOUT,*) 'integer, parameter :: NPROCTOT_VAL = ',NPROCTOT
-
- write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_VAL_CM = ', &
- max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE))
- write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_VAL_OC = ', &
- max(NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE))
- write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_VAL_IC = ', &
- max(NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE))
-
- 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
- endif
-
- write(IOUT,*) 'integer, parameter :: NUMMSGS_FACES_VAL = ',NPROC_XI*NUM_FACES*NUM_MSG_TYPES
- write(IOUT,*) 'integer, parameter :: NCORNERSCHUNKS_VAL = ',NCORNERSCHUNKS
-
- if(ATTENUATION) then
- if(ATTENUATION_3D) then
- att1 = NGLLX
- att2 = NGLLY
- att3 = NGLLZ
- att4 = NSPEC(IREGION_CRUST_MANTLE)
- att5 = NSPEC(IREGION_INNER_CORE)
- else
- att1 = 1
- att2 = 1
- att3 = 1
- att4 = NRAD_ATTENUATION
- att5 = NRAD_ATTENUATION
- endif
- else
- att1 = 1
- att2 = 1
- att3 = 1
- att4 = 1
- att5 = 1
- endif
-
- write(IOUT,*) 'integer, parameter :: ATT1 = ',att1
- write(IOUT,*) 'integer, parameter :: ATT2 = ',att2
- write(IOUT,*) 'integer, parameter :: ATT3 = ',att3
- write(IOUT,*) 'integer, parameter :: ATT4 = ',att4
- write(IOUT,*) 'integer, parameter :: ATT5 = ',att5
-
- write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_XMIN_XMAX_CM = ',NSPEC2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE)
- write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_YMIN_YMAX_CM = ',NSPEC2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE)
- write(IOUT,*) 'integer, parameter :: NSPEC2D_BOTTOM_CM = ',NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
- write(IOUT,*) 'integer, parameter :: NSPEC2D_TOP_CM = ',NSPEC2D_TOP(IREGION_CRUST_MANTLE)
-
- write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_XMIN_XMAX_IC = ',NSPEC2DMAX_XMIN_XMAX(IREGION_INNER_CORE)
- write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_YMIN_YMAX_IC = ',NSPEC2DMAX_YMIN_YMAX(IREGION_INNER_CORE)
- write(IOUT,*) 'integer, parameter :: NSPEC2D_BOTTOM_IC = ',NSPEC2D_BOTTOM(IREGION_INNER_CORE)
- write(IOUT,*) 'integer, parameter :: NSPEC2D_TOP_IC = ',NSPEC2D_TOP(IREGION_INNER_CORE)
-
- write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_XMIN_XMAX_OC = ',NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE)
- write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_YMIN_YMAX_OC = ',NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE)
- write(IOUT,*) 'integer, parameter :: NSPEC2D_BOTTOM_OC = ',NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
- write(IOUT,*) 'integer, parameter :: NSPEC2D_TOP_OC = ',NSPEC2D_TOP(IREGION_OUTER_CORE)
-
- ! for boundary kernels
-
- if (SAVE_BOUNDARY_MESH) then
- NSPEC2D_MOHO = NSPEC2D_TOP(IREGION_CRUST_MANTLE)
- NSPEC2D_400 = NSPEC2D_MOHO / 4
- NSPEC2D_670 = NSPEC2D_400
- NSPEC2D_CMB = NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
- NSPEC2D_ICB = NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
- else
- NSPEC2D_MOHO = 1
- NSPEC2D_400 = 1
- NSPEC2D_670 = 1
- NSPEC2D_CMB = 1
- NSPEC2D_ICB = 1
- endif
-
- write(IOUT,*) 'integer, parameter :: NSPEC2D_MOHO = ',NSPEC2D_MOHO
- write(IOUT,*) 'integer, parameter :: NSPEC2D_400 = ',NSPEC2D_400
- write(IOUT,*) 'integer, parameter :: NSPEC2D_670 = ',NSPEC2D_670
- write(IOUT,*) 'integer, parameter :: NSPEC2D_CMB = ',NSPEC2D_CMB
- write(IOUT,*) 'integer, parameter :: NSPEC2D_ICB = ',NSPEC2D_ICB
-
- close(IOUT)
-
- end subroutine save_header_file
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/go_mesher_solver_lsf_globe.bash (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/go_mesher_solver_lsf_globe.bash)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/go_mesher_solver_lsf_globe.bash (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/go_mesher_solver_lsf_globe.bash 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,42 @@
+#!/bin/bash
+#BSUB -o OUTPUT_FILES/%J.o
+#BSUB -a mpich_gm
+#BSUB -J go_mesher_solver_lsf
+
+if [ -z $USER ]; then
+ echo "could not run go_mesher_solver_...bash as no USER env is set"
+ exit 2
+fi
+
+# script to run the mesher and the solver
+
+# read DATA/Par_file to get information about the run
+
+# compute total number of nodes needed
+NPROC_XI=`grep NPROC_XI DATA/Par_file | cut -d = -f 2 `
+NPROC_ETA=`grep NPROC_ETA DATA/Par_file | cut -d = -f 2`
+NCHUNKS=`grep NCHUNKS DATA/Par_file | cut -d = -f 2 `
+
+# total number of nodes is the product of the values read
+numnodes=$(( $NCHUNKS * $NPROC_XI * $NPROC_ETA ))
+
+rm -r -f OUTPUT_FILES
+mkdir OUTPUT_FILES
+
+# obtain lsf job information
+echo "$LSB_MCPU_HOSTS" > OUTPUT_FILES/lsf_machines
+echo "$LSB_JOBID" > OUTPUT_FILES/jobid
+
+./remap_lsf_machines.pl OUTPUT_FILES/lsf_machines >OUTPUT_FILES/machines
+
+echo starting MPI mesher on $numnodes processors
+echo " "
+echo starting run in current directory $PWD
+echo " "
+
+sleep 2
+
+#### use this on LSF
+mpirun.lsf --gm-no-shmem --gm-copy-env $PWD/xmeshfem3D
+####mpirun.lsf --gm-no-shmem --gm-copy-env $PWD/xspecfem3D
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/remap_lsf_machines.pl (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/remap_lsf_machines.pl)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/remap_lsf_machines.pl (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/remap_lsf_machines.pl 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,20 @@
+#!/usr/bin/perl -w
+
+if (@ARGV != 1) {die("remap_lsf_machines.pl machinefile\n");}
+
+$machine = $ARGV[0];
+
+open(FILE,"$machine") or die("Error opening file $machine\n");
+(@junk) = <FILE>;
+close(FILE);
+
+for($i=0;$i<@junk;$i++) {
+ @node_array = split(" ",$junk[$i]);
+ foreach $node (@node_array) {
+ next if ( $node =~ /^[0-9]/ );
+ push(@nodes, $node);
+ }
+}
+foreach $node (@nodes) {
+ print "$node\n";
+}
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/run_lsf_globe_big.bash (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/run_lsf_globe_big.bash)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/run_lsf_globe_big.bash (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/scripts/run_lsf_globe_big.bash 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,21 @@
+#!/bin/bash
+
+# use the normal queue unless otherwise directed
+queue="-q normal"
+if [ $# -eq 1 ]; then
+ echo "Setting the queue to $1"
+ queue="-q $1"
+fi
+
+# compute total number of nodes needed
+NPROC_XI=`grep NPROC_XI DATA/Par_file | cut -d = -f 2`
+NPROC_ETA=`grep NPROC_ETA DATA/Par_file | cut -d = -f 2 `
+NCHUNKS=`grep NCHUNKS DATA/Par_file | cut -d = -f 2`
+
+# total number of nodes is the product of the values read
+numnodes=$(( $NCHUNKS * $NPROC_XI * $NPROC_ETA ))
+
+echo "Submitting job"
+bsub $queue -n $numnodes -W 14:00 -C 0 < go_mesher_solver_lsf_globe.bash
+#bsub $queue -n $numnodes -W 144:00 -C 0 < go_mesher_solver_lsf_globe.bash
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sea99_s_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sea99_s_model.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sea99_s_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,157 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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_sea99_s_model(SEA99M_V)
-
- implicit none
-
- include "constants.h"
-
-! 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
-
- integer :: i,ia,io,j
-
-!----------------------- choose input file: ------------------
-! relative anomaly
-
-
- open(1,file='DATA/Lebedev_sea99/sea99_dvsvs')
-
-!----------------------- read input file: ------------------
-
- do i = 1, 6
- read(1,*)
- enddo
- read(1,*) SEA99M_V%sea99_ndep
- read(1,*) (SEA99M_V%sea99_depth(i), i = 1, SEA99M_V%sea99_ndep)
- read(1,*)
- read(1,*) SEA99M_V%alatmin, SEA99M_V%alatmax
- read(1,*) SEA99M_V%alonmin, SEA99M_V%alonmax
- read(1,*) SEA99M_V%sea99_ddeg,SEA99M_V%sea99_nlat,SEA99M_V%sea99_nlon
- if (SEA99M_V%sea99_nlat .ne. nint((SEA99M_V%alatmax-SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg)+1) then
- stop 'alatmin,alatmax,sea99_nlat'
- endif
- if (SEA99M_V%sea99_nlon .ne. nint((SEA99M_V%alonmax-SEA99M_V%alonmin)/SEA99M_V%sea99_ddeg)+1) then
- stop 'alonmin,alonmax,sea99_nlon'
- endif
- read(1,*)
- do j = 1, SEA99M_V%sea99_ndep
- do ia = 1, SEA99M_V%sea99_nlat
- read (1,*) (SEA99M_V%sea99_vs(ia,io,j), io = 1, SEA99M_V%sea99_nlon)
- enddo
- enddo
-
-end subroutine read_sea99_s_model
-
-subroutine sea99_s_model(radius,theta,phi,dvs,SEA99M_V)
-
- implicit none
-
- include "constants.h"
-
-! 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
-
- integer :: id1,i,ilat,ilon
- double precision :: alat1,alon1,radius,theta,phi,dvs
- double precision :: xxx,yyy,dep,pla,plo,xd1,dd1,dd2,ddd(2)
- !----------------------- depth in the model ------------------
- dep=R_EARTH_KM*(R_UNIT_SPHERE - radius)
- pla=90.0d0 - theta/DEGREES_TO_RADIANS
- plo=phi/DEGREES_TO_RADIANS
- if (dep .le. SEA99M_V%sea99_depth(1)) then
- id1 = 1
- xd1 = 0
- else if (dep .ge. SEA99M_V%sea99_depth(SEA99M_V%sea99_ndep)) then
- id1 = SEA99M_V%sea99_ndep
- xd1 = 0
- else
- do i = 2, SEA99M_V%sea99_ndep
- if (dep .le. SEA99M_V%sea99_depth(i)) then
- id1 = i-1
- xd1 = (dep-SEA99M_V%sea99_depth(i-1)) / (SEA99M_V%sea99_depth(i) - SEA99M_V%sea99_depth(i-1))
- go to 1
- endif
- enddo
- endif
-1 continue
-
-!----------------------- value at a point ---------------------
-!----- approximate interpolation, OK for the (dense) 1-degree sampling ------
-
- ilat = int((pla - SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg) + 1
- ilon = int((plo - SEA99M_V%alonmin)/SEA99M_V%sea99_ddeg) + 1
- alat1 = SEA99M_V%alatmin + (ilat-1)*SEA99M_V%sea99_ddeg
- alon1 = SEA99M_V%alonmin + (ilon-1)*SEA99M_V%sea99_ddeg
-
- do i = 1, 2
- xxx = (pla-alat1)/SEA99M_V%sea99_ddeg
- yyy = SEA99M_V%sea99_vs(ilat+1,ilon,id1+i-1)-SEA99M_V%sea99_vs(ilat,ilon,id1+i-1)
- dd1 = SEA99M_V%sea99_vs(ilat,ilon,id1+i-1) + yyy*xxx
- yyy = SEA99M_V%sea99_vs(ilat+1,ilon+1,id1+i-1)-SEA99M_V%sea99_vs(ilat,ilon+1,id1+i-1)
- dd2 = SEA99M_V%sea99_vs(ilat,ilon+1,id1+i-1) + yyy*xxx
- xxx = (plo-alon1)/SEA99M_V%sea99_ddeg
- yyy = dd2 - dd1
- ddd(i) = dd1 + yyy*xxx
- enddo
- dvs = ddd(1) + (ddd(2)-ddd(1)) * xd1
- if(dvs>1.d0) dvs=0.0d0
-
-end subroutine sea99_s_model
-
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/constants.h (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/constants.h)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/constants.h (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/constants.h 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,489 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! constants.h. Generated from constants.h.in by configure.
+
+!
+!--- user can modify parameters below
+!
+
+! deccrease the number of MPI messages by 3 but increase the size
+! of several MPI buffers by 3 but in order to do that
+ logical, parameter :: FEWER_MESSAGES_LARGER_BUFFERS = .true.
+
+!
+! solver in single or double precision depending on the machine (4 or 8 bytes)
+!
+! ALSO CHANGE FILE precision.h ACCORDINGLY
+!
+ integer, parameter :: SIZE_REAL = 4, SIZE_DOUBLE = 8
+
+! usually the size of integer and logical variables is the same as regular single-precision real variable
+ integer, parameter :: SIZE_INTEGER = SIZE_REAL
+ integer, parameter :: SIZE_LOGICAL = SIZE_REAL
+
+! set to SIZE_REAL to run in single precision
+! set to SIZE_DOUBLE to run in double precision (increases memory size by 2)
+ integer, parameter :: CUSTOM_REAL = SIZE_REAL
+
+! input, output and main MPI I/O files
+ integer, parameter :: ISTANDARD_OUTPUT = 6
+ integer, parameter :: IIN = 40,IOUT = 41,IOUT_SAC = 903
+! local file unit for output of buffers
+ integer, parameter :: IOUT_BUFFERS = 35
+! uncomment this to write messages to a text file
+ integer, parameter :: IMAIN = 42
+! uncomment this to write messages to the screen (slows down the code)
+! integer, parameter :: IMAIN = ISTANDARD_OUTPUT
+
+! R_EARTH is the radius of the bottom of the oceans (radius of Earth in m)
+ double precision, parameter :: R_EARTH = 6371000.d0
+! uncomment line below for PREM with oceans
+! double precision, parameter :: R_EARTH = 6368000.d0
+
+! average density in the full Earth to normalize equation
+ double precision, parameter :: RHOAV = 5514.3d0
+
+! for topography/bathymetry model
+
+!!--- ETOPO5 5-minute model, smoothed Harvard version
+!! size of topography and bathymetry file
+! integer, parameter :: NX_BATHY = 4320,NY_BATHY = 2160
+!! resolution of topography file in minutes
+! integer, parameter :: RESOLUTION_TOPO_FILE = 5
+!! pathname of the topography file
+! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo5_smoothed_Harvard.dat'
+
+!--- ETOPO4 4-minute model created by subsampling and smoothing etopo-2
+! size of topography and bathymetry file
+ integer, parameter :: NX_BATHY = 5400,NY_BATHY = 2700
+! resolution of topography file in minutes
+ integer, parameter :: RESOLUTION_TOPO_FILE = 4
+! pathname of the topography file
+ character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo4_smoothed_window_7.dat'
+
+!!--- ETOPO2 2-minute model, not implemented yet
+!! size of topography and bathymetry file
+! integer, parameter :: NX_BATHY = 10800,NY_BATHY = 5400
+!! resolution of topography file in minutes
+! integer, parameter :: RESOLUTION_TOPO_FILE = 2
+!! pathname of the topography file
+! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo2_smoothed_window7.dat'
+
+! maximum depth of the oceans in trenches and height of topo in mountains
+! to avoid taking into account spurious oscillations in global model ETOPO
+ logical, parameter :: USE_MAXIMUM_HEIGHT_TOPO = .false.
+ integer, parameter :: MAXIMUM_HEIGHT_TOPO = +20000
+ logical, parameter :: USE_MAXIMUM_DEPTH_OCEANS = .false.
+ integer, parameter :: MAXIMUM_DEPTH_OCEANS = -20000
+
+! minimum thickness in meters to include the effect of the oceans and topo
+ double precision, parameter :: MINIMUM_THICKNESS_3D_OCEANS = 100.d0
+
+! number of GLL points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! flag to exclude elements that are too far from target in source detection
+ logical, parameter :: USE_DISTANCE_CRITERION = .true.
+
+! flag to display detailed information about location of stations
+ logical, parameter :: DISPLAY_DETAILS_STATIONS = .false.
+
+! maximum length of station and network name for receivers
+ integer, parameter :: MAX_LENGTH_STATION_NAME = 32
+ integer, parameter :: MAX_LENGTH_NETWORK_NAME = 8
+
+! we mimic a triangle of half duration equal to half_duration_triangle
+! using a Gaussian having a very close shape, as explained in Figure 4.2
+! of the manual. This source decay rate to mimic an equivalent triangle
+! was found by trial and error
+ double precision, parameter :: SOURCE_DECAY_MIMIC_TRIANGLE = 1.628d0
+
+! maximum number of sources to locate simultaneously
+ integer, parameter :: NSOURCES_SUBSET_MAX = 1000
+
+! distance threshold (in km) above which we consider that a receiver
+! is located outside the mesh and therefore excluded from the station list
+ double precision, parameter :: THRESHOLD_EXCLUDE_STATION = 50.d0
+
+! the first doubling is implemented right below the Moho
+! it seems optimal to implement the three other doublings at these depths
+! in the mantle
+ double precision, parameter :: DEPTH_SECOND_DOUBLING_OPTIMAL = 1650000.d0
+! in the outer core
+ double precision, parameter :: DEPTH_THIRD_DOUBLING_OPTIMAL = 3860000.d0
+! in the outer core
+ double precision, parameter :: DEPTH_FOURTH_DOUBLING_OPTIMAL = 5000000.d0
+
+! Boundary Mesh -- save Moho, 400, 670 km discontinuity topology files (in
+! the mesher) and use them for the computation of boundary kernel (in the solver)
+ logical, parameter :: SAVE_BOUNDARY_MESH = .false.
+
+! this parameter must be set to .true. to compute anisotropic kernels
+! in crust and mantle (related to the 21 Cij in geographical coordinates)
+! default is .false. to compute isotropic kernels (related to alpha and beta)
+ logical, parameter :: ANISOTROPIC_KL = .false.
+
+! print date and time estimate of end of run in another country,
+! in addition to local time.
+! 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.
+! The time difference with that remote location can be positive or negative
+ logical, parameter :: ADD_TIME_ESTIMATE_ELSEWHERE = .false.
+ integer, parameter :: HOURS_TIME_DIFFERENCE = +9
+ integer, parameter :: MINUTES_TIME_DIFFERENCE = +0
+
+!
+!--- debugging flags
+!
+
+! flags to actually assemble with MPI or not
+! and to actually match fluid and solid regions of the Earth or not
+! should always be set to true except when debugging code
+ logical, parameter :: ACTUALLY_ASSEMBLE_MPI_SLICES = .true.
+ logical, parameter :: ACTUALLY_ASSEMBLE_MPI_CHUNKS = .true.
+ logical, parameter :: ACTUALLY_COUPLE_FLUID_CMB = .true.
+ logical, parameter :: ACTUALLY_COUPLE_FLUID_ICB = .true.
+
+!! DK DK UGLY added this in case we are running on MareNostrum in Barcelona
+!! DK DK UGLY because we then need some calls to the system to use GPFS
+ logical, parameter :: RUN_ON_MARENOSTRUM_BARCELONA = .false.
+
+!------------------------------------------------------
+!----------- do not modify anything below -------------
+!------------------------------------------------------
+
+! on some processors (e.g. Pentiums) it is necessary to suppress underflows
+! by using a small initial field instead of zero
+ logical, parameter :: FIX_UNDERFLOW_PROBLEM = .true.
+
+! some useful constants
+ double precision, parameter :: PI = 3.141592653589793d0
+ double precision, parameter :: TWO_PI = 2.d0 * PI
+ double precision, parameter :: PI_OVER_FOUR = PI / 4.d0
+
+! to convert angles from degrees to radians
+ double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+! dimension of the boundaries of the slices
+ integer, parameter :: NDIM2D = 2
+
+! number of nodes for 2D and 3D shape functions for hexahedra with 27 nodes
+ integer, parameter :: NGNOD = 27, NGNOD2D = 9
+
+! gravitational constant
+ double precision, parameter :: GRAV = 6.6723d-11
+
+! a few useful constants
+ double precision, parameter :: ZERO = 0.d0,ONE = 1.d0,TWO = 2.d0,HALF = 0.5d0
+
+ real(kind=CUSTOM_REAL), parameter :: &
+ ONE_THIRD = 1._CUSTOM_REAL/3._CUSTOM_REAL, &
+ TWO_THIRDS = 2._CUSTOM_REAL/3._CUSTOM_REAL, &
+ FOUR_THIRDS = 4._CUSTOM_REAL/3._CUSTOM_REAL
+
+! very large and very small values
+ double precision, parameter :: HUGEVAL = 1.d+30,TINYVAL = 1.d-9
+
+! very large real value declared independently of the machine
+ real(kind=CUSTOM_REAL), parameter :: HUGEVAL_SNGL = 1.e+30_CUSTOM_REAL
+
+! very large integer value
+ integer, parameter :: HUGEINT = 100000000
+
+! normalized radius of free surface
+ double precision, parameter :: R_UNIT_SPHERE = ONE
+
+! same radius in km
+ double precision, parameter :: R_EARTH_KM = R_EARTH / 1000.d0
+
+! fixed thickness of 3 km for PREM oceans
+ double precision, parameter :: THICKNESS_OCEANS_PREM = 3000.d0 / R_EARTH
+
+! shortest radius at which crust is implemented (80 km depth)
+! to be constistent with the D80 discontinuity, we impose the crust only above it
+ double precision, parameter :: R_DEEPEST_CRUST = (R_EARTH - 80000.d0) / R_EARTH
+
+! maximum number of chunks (full sphere)
+ integer, parameter :: NCHUNKS_MAX = 6
+
+! define block type based upon chunk number (between 1 and 6)
+! do not change this numbering, chunk AB must be number 1 for central cube
+ integer, parameter :: CHUNK_AB = 1
+ integer, parameter :: CHUNK_AC = 2
+ integer, parameter :: CHUNK_BC = 3
+ integer, parameter :: CHUNK_AC_ANTIPODE = 4
+ integer, parameter :: CHUNK_BC_ANTIPODE = 5
+ integer, parameter :: CHUNK_AB_ANTIPODE = 6
+
+! maximum number of regions in the mesh
+ integer, parameter :: MAX_NUM_REGIONS = 3
+
+! define flag for regions of the global Earth mesh
+ integer, parameter :: IREGION_CRUST_MANTLE = 1
+ integer, parameter :: IREGION_OUTER_CORE = 2
+ integer, parameter :: IREGION_INNER_CORE = 3
+
+! define flag for elements
+ integer, parameter :: IFLAG_CRUST = 1
+
+ integer, parameter :: IFLAG_80_MOHO = 2
+ integer, parameter :: IFLAG_220_80 = 3
+ integer, parameter :: IFLAG_670_220 = 4
+ integer, parameter :: IFLAG_MANTLE_NORMAL = 5
+
+ integer, parameter :: IFLAG_OUTER_CORE_NORMAL = 6
+
+ integer, parameter :: IFLAG_INNER_CORE_NORMAL = 7
+ integer, parameter :: IFLAG_MIDDLE_CENTRAL_CUBE = 8
+ integer, parameter :: IFLAG_BOTTOM_CENTRAL_CUBE = 9
+ integer, parameter :: IFLAG_TOP_CENTRAL_CUBE = 10
+ integer, parameter :: IFLAG_IN_FICTITIOUS_CUBE = 11
+
+ integer, parameter :: NSPEC2D_XI_SUPERBRICK = 8
+ integer, parameter :: NSPEC2D_ETA_SUPERBRICK = 8
+ integer, parameter :: NSPEC2D_XI_SUPERBRICK_1L = 6
+ integer, parameter :: NSPEC2D_ETA_SUPERBRICK_1L = 6
+
+! dummy flag used for mesh display purposes only
+ integer, parameter :: IFLAG_DUMMY = 100
+
+! max number of layers that are used in the radial direction to build the full mesh
+ integer, parameter :: MAX_NUMBER_OF_MESH_LAYERS = 15
+
+! define number of spectral elements and points in basic symmetric mesh doubling superbrick
+ integer, parameter :: NSPEC_DOUBLING_SUPERBRICK = 32
+ integer, parameter :: NGLOB_DOUBLING_SUPERBRICK = 67
+ integer, parameter :: NSPEC_SUPERBRICK_1L = 28
+ integer, parameter :: NGLOB_SUPERBRICK_1L = 58
+ integer, parameter :: NGNOD_EIGHT_CORNERS = 8
+
+! define flag for reference 1D Earth model
+ integer, parameter :: REFERENCE_MODEL_PREM = 1
+ integer, parameter :: REFERENCE_MODEL_IASP91 = 2
+ integer, parameter :: REFERENCE_MODEL_1066A = 3
+ integer, parameter :: REFERENCE_MODEL_AK135 = 4
+ integer, parameter :: REFERENCE_MODEL_REF = 5
+ integer, parameter :: REFERENCE_MODEL_JP1D = 6
+ integer, parameter :: REFERENCE_MODEL_SEA1D = 7
+
+! define flag for 3D Earth model
+ integer, parameter :: THREE_D_MODEL_S20RTS = 1
+ integer, parameter :: THREE_D_MODEL_S362ANI = 2
+ integer, parameter :: THREE_D_MODEL_S362WMANI = 3
+ integer, parameter :: THREE_D_MODEL_S362ANI_PREM = 4
+ integer, parameter :: THREE_D_MODEL_S29EA = 5
+ integer, parameter :: THREE_D_MODEL_SEA99_JP3D = 6
+ integer, parameter :: THREE_D_MODEL_SEA99 = 7
+ integer, parameter :: THREE_D_MODEL_JP3D = 8
+
+! define flag for regions of the global Earth for attenuation
+ integer, parameter :: NUM_REGIONS_ATTENUATION = 5
+
+ integer, parameter :: IREGION_ATTENUATION_INNER_CORE = 1
+ integer, parameter :: IREGION_ATTENUATION_CMB_670 = 2
+ integer, parameter :: IREGION_ATTENUATION_670_220 = 3
+ integer, parameter :: IREGION_ATTENUATION_220_80 = 4
+ integer, parameter :: IREGION_ATTENUATION_80_SURFACE = 5
+ integer, parameter :: IREGION_ATTENUATION_UNDEFINED = 6
+
+! number of standard linear solids for attenuation
+ integer, parameter :: N_SLS = 3
+
+! computation of standard linear solids in meshfem3D
+! ATTENUATION_COMP_RESOLUTION: Number of Digits after decimal
+! ATTENUATION_COMP_MAXIMUM: Maximum Q Value
+ integer, parameter :: ATTENUATION_COMP_RESOLUTION = 1
+ integer, parameter :: ATTENUATION_COMP_MAXIMUM = 5000
+
+! for lookup table for attenuation every 100 m in radial direction of Earth model
+ integer, parameter :: NRAD_ATTENUATION = 70000
+ double precision, parameter :: TABLE_ATTENUATION = R_EARTH_KM * 10.0d0
+
+! for determination of the attenuation period range
+! if this is set to .true. then the hardcoded values will be used
+! otherwise they are computed automatically from the Number of elements
+! This *may* be a useful parameter for Benchmarking against older versions
+ logical, parameter :: ATTENUATION_RANGE_PREDEFINED = .false.
+
+! flag for the four edges of each slice and for the bottom edge
+ integer, parameter :: XI_MIN = 1
+ integer, parameter :: XI_MAX = 2
+ integer, parameter :: ETA_MIN = 3
+ integer, parameter :: ETA_MAX = 4
+ integer, parameter :: BOTTOM = 5
+
+! flags to select the right corner in each slice
+ integer, parameter :: ILOWERLOWER = 1
+ integer, parameter :: ILOWERUPPER = 2
+ integer, parameter :: IUPPERLOWER = 3
+ integer, parameter :: IUPPERUPPER = 4
+
+! number of points in each AVS or OpenDX quadrangular cell for movies
+ integer, parameter :: NGNOD2D_AVS_DX = 4
+
+! number of faces a given slice can share with other slices
+! this is at most 2, except when there is only once slice per chunk
+! in which case it is 4
+ integer, parameter :: NUMFACES_SHARED = 2 !!!!! DK DK removed support for one slice only 4
+
+! number of corners a given slice can share with other slices
+! this is at most 1, except when there is only once slice per chunk
+! in which case it is 4
+ integer, parameter :: NUMCORNERS_SHARED = 1 !!!!!! DK DK removed support for one slice only 4
+
+! number of layers in PREM
+ integer, parameter :: NR = 640
+
+! smallest real number on many machines = 1.1754944E-38
+! largest real number on many machines = 3.4028235E+38
+! small negligible initial value to avoid very slow underflow trapping
+! but not too small to avoid trapping on velocity and acceleration in Newmark
+ real(kind=CUSTOM_REAL), parameter :: VERYSMALLVAL = 1.E-24_CUSTOM_REAL
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=CUSTOM_REAL), parameter :: STABILITY_THRESHOLD = 1.E+25_CUSTOM_REAL
+
+! geometrical tolerance for boundary detection
+ double precision, parameter :: SMALLVAL = 0.00001d0
+
+! small tolerance for conversion from x y z to r theta phi
+ double precision, parameter :: SMALL_VAL_ANGLE = 1.d-10
+
+! geometry tolerance parameter to calculate number of independent grid points
+! sensitive to actual size of model, assumes reference sphere of radius 1
+! this is an absolute value for normalized coordinates in the Earth
+ double precision, parameter :: SMALLVALTOL = 1.d-10
+
+! do not use tags for MPI messages, use dummy tag instead
+ integer, parameter :: itag = 0,itag2 = 0
+
+! for the Gauss-Lobatto-Legendre points and weights
+ double precision, parameter :: GAUSSALPHA = 0.d0,GAUSSBETA = 0.d0
+
+! number of lines per source in CMTSOLUTION file
+ integer, parameter :: NLINES_PER_CMTSOLUTION_SOURCE = 13
+
+! number of iterations to solve the non linear system for xi and eta
+ integer, parameter :: NUM_ITER = 4
+
+! number of hours per day for rotation rate of the Earth
+ double precision, parameter :: HOURS_PER_DAY = 24.d0
+
+! for lookup table for gravity every 100 m in radial direction of Earth model
+ integer, parameter :: NRAD_GRAVITY = 70000
+
+!!!!!!!!!!!!!! parameters added for the thread-safe version of the code
+! number of layers in DATA/1066a/1066a.dat
+ integer, parameter :: NR_1066A = 160
+
+! number of layers in DATA/ak135/ak135.dat
+ integer, parameter :: NR_AK135 = 144
+
+! number of layers in DATA/s362ani/REF
+ integer, parameter :: NR_REF = 750
+
+! number of layers in DATA/Lebedev_sea99 1D model
+ integer, parameter :: NR_SEA1D = 163
+
+! three_d_mantle_model_constants
+ integer, parameter :: NK = 20,NS = 20,ND = 1
+
+! Japan 3D model (Zhao, 1994) constants
+ integer, parameter :: MPA=42,MRA=48,MHA=21,MPB=42,MRB=48,MHB=18
+ integer, parameter :: MKA=2101,MKB=2101
+
+! The meaningful range of Zhao et al.'s model (1994) is as follows:
+! latitude : 32 - 45 N
+! longitude: 130-145 E
+! depth : 0 - 500 km
+! The deepest Moho beneath Japan is 40 km
+ double precision,parameter :: LAT_MAX = 45.d0
+ double precision,parameter :: LAT_MIN = 32.d0
+ double precision,parameter :: LON_MAX = 145.d0
+ double precision,parameter :: LON_MIN = 130.d0
+ double precision,parameter :: DEP_MAX = 500.d0
+
+! crustal_model_constants
+ ! crustal model parameters for crust2.0
+ integer, parameter :: NKEYS_CRUST = 359
+ integer, parameter :: NLAYERS_CRUST = 8
+ integer, parameter :: NCAP_CRUST = 180
+ ! use sedimentary layers of crust 2.0
+ logical, parameter :: INCLUDE_SEDIMENTS_CRUST = .true.
+!!!!!!!!!!!!!! end of parameters added for the thread-safe version of the code
+
+! to inflate the central cube (set to 0.d0 for a non-inflated cube)
+ double precision, parameter :: CENTRAL_CUBE_INFLATE_FACTOR = 0.41d0
+
+! for the stretching of crustal elements in the case of 3D models
+ double precision, parameter :: MAX_RATIO_CRUST_STRETCHING = 0.6d0
+
+! to suppress the crustal layers (replaced by an extension of the mantle: R_EARTH is not modified, but no more crustal doubling)
+ logical, parameter :: SUPPRESS_CRUSTAL_MESH = .false.
+
+! to add a fourth doubling at the bottom of the outer core
+ logical, parameter :: ADD_4TH_DOUBLING = .false.
+
+! parameters to cut the doubling brick
+
+! this to cut the superbrick: 3 possibilities, 4 cases max / possibility
+! three possibilities: (cut in xi and eta) or (cut in xi) or (cut in eta)
+! case 1: (ximin and etamin) or ximin or etamin
+! case 2: (ximin and etamax) or ximax or etamax
+! case 3: ximax and etamin
+! case 4: ximax and etamax
+ integer, parameter :: NB_CUT_CASE = 4
+
+! corner 1: ximin and etamin
+! corner 2: ximax and etamin
+! corner 3: ximax and etamax
+! corner 4: ximin and etamax
+ integer, parameter :: NB_SQUARE_CORNERS = 4
+
+! two possibilities: xi or eta
+! face 1: ximin or etamin
+! face 2: ximax or etamax
+ integer, parameter :: NB_SQUARE_EDGES_ONEDIR = 2
+
+! this for the geometry of the basic doubling brick
+ integer, parameter :: NSPEC_DOUBLING_BASICBRICK = 8
+ integer, parameter :: NGLOB_DOUBLING_BASICBRICK = 27
+
+! for Cuthill-McKee (1969) permutation
+ logical, parameter :: PERFORM_CUTHILL_MCKEE = .false.
+ integer, parameter :: NGNOD_HEXAHEDRA = 8
+! perform classical or multi-level Cuthill-McKee ordering
+ logical, parameter :: CMcK_MULTI = .false.
+! maximum size if multi-level Cuthill-McKee ordering
+ integer, parameter :: LIMIT_MULTI_CUTHILL = 50
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/flags.guess (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/flags.guess)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/flags.guess (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/flags.guess 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,183 @@
+#!/bin/sh
+
+# Attempt to guess suitable flags for the Fortran compiler.
+
+# Use AC_CANONICAL_BUILD (and package config.guess, etc.) in the future?
+if test x"$UNAME_MS" = x; then
+ UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
+ UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
+ UNAME_MS="${UNAME_MACHINE}:${UNAME_SYSTEM}"
+fi
+
+case $FC in
+ pgf90|*/pgf90)
+ #
+ # Beowulf Portland pgf90
+ #
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="-fast -Mnobounds -Mneginfo -Mdclchk -Knoieee" # -mcmodel=medium
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-fast -Mnobounds -Mneginfo -Mdclchk -Knoieee -Ktrap=none -Minline" # -mcmodel=medium
+ fi
+ ;;
+ ifort|*/ifort)
+ #
+ # Intel ifort Fortran90 for Linux
+ #
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="-O3 -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds -align sequence -assume byterecl -i-dynamic -ftrapuv -fpe0 -no-ftz -traceback" # -mcmodel=medium
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ # standard options
+ FLAGS_NO_CHECK="-O3 -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds -align sequence -assume byterecl -i-dynamic -fpe3 -no-ftz" # -mcmodel=medium
+ # Pangu at Caltech
+ #FLAGS_NO_CHECK = $(IFORT_PROF) -vec_report0 -O2 -static -ip -xP -Wl,--allow-multiple-definition -L $$IFORT_ROOT/lib -limf -lirc
+ # debug with range checking
+ #FLAGS_NO_CHECK = -O0 -static -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check bounds
+ fi
+ #MPI_LIBS = -Vaxlib
+ ;;
+ gfortran|*/gfortran|f95|*/f95)
+ #
+ # GNU gfortran
+ #
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-std=gnu -fimplicit-none -frange-check -O3 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow -fno-trapping-math" # -mcmodel=medium
+ fi
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="\$(FLAGS_NO_CHECK)" # -fbounds-check
+ fi
+ ;;
+ g95|*/g95)
+ #
+ # g95 (free f95 compiler from http://www.g95.org)
+ #
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="-O"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-O"
+ fi
+ ;;
+ f90|*/f90)
+ case $UNAME_MS in
+ i*86:Linux | x86_64:Linux)
+ ################ PC Linux #################
+ #
+ # AbSoft
+ #
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="-s -O2 -cpu:p7 -v -YDEALLOC=ALL"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="\$(FLAGS_CHECK)"
+ fi
+ ;;
+ *:IRIX*)
+ ################ SGI Irix #################
+ if test x"$MPIFC" = x; then
+ MPIFC=$FC
+ if test x"$MPILIBS" = x; then
+ MPILIBS="-lmpi -lfastm -lfpe"
+ fi
+ fi
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="\$(FLAGS_NO_CHECK) -check_bounds"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-ansi -u -64 -O3 -OPT:Olimit=0 -OPT:roundoff=3 -OPT:IEEE_arithmetic=3 -r10000 -mips4"
+ fi
+ ;;
+ alpha:OSF1)
+ ################## Compaq Dec Alpha #################
+ if test x"$MPIFC" = x; then
+ MPIFC=$FC
+ if test x"$MPILIBS" = x; then
+ MPILIBS="-lfmpi -lmpi"
+ fi
+ fi
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="\$(FLAGS_NO_CHECK) -check bounds"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-fast -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nounderflow"
+ fi
+ ;;
+ SX-*:SUPER-UX | ES:ESOS)
+ ################## Earth Simulator and NEC SX-5 ##################
+ if test x"$MPIFC" = x; then
+ MPIFC=$FC
+ fi
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="-C hopt -R2 -Wf\" -L nostdout noinclist mrgmsg noeject -msg b -pvctl loopcnt=14000000 expand=10 fullmsg vecthreshold=20 -s\" -pi auto line=100 exp=swap_all,rank"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="\$(FLAGS_CHECK)"
+ fi
+ ;;
+ esac
+ ;;
+ lf95|*/lf95)
+ #
+ # Lahey f90
+ #
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="--warn --wo --tpp --f95 --dal -O --chk"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="--warn --wo --tpp --f95 --dal -O"
+ fi
+ ;;
+ ######## IBM ######
+ mpxlf*|*/mpxlf*)
+ if test x"$MPIFC" = x; then
+ MPIFC=$FC
+ fi
+ ;;
+ *xlf*|*/*xlf*)
+ #
+ # do NOT remove option -qsave otherwise the IBM compiler allocates the
+ # arrays in the stack and the code crashes if the stack size is too
+ # small (which is often the case)
+ #
+ # on IBM with xlf one should also set
+ #
+ # CC = xlc_r
+ # CFLAGS = -O2 -q64
+ #
+ # or
+ #
+ # CC = gcc
+ # CFLAGS = -O2 -m64
+ #
+ # for the C compiler when using -q64 for the Fortran compiler
+ #
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-O3 -qsave -qstrict -q64 -qtune=auto -qarch=auto -qcache=auto -qfree=f90 -Q -qsuffix=f=f90 -qhalt=w -qlanglvl=2003pure" # -qflttrap=en:ov:zero:inv
+ # on MareNostrum at the Barcelona SuperComputing Center (Spain) use
+ # -qtune=ppc970 -qarch=ppc64v instead of -qtune=auto -qarch=auto
+ fi
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="\$(FLAGS_NO_CHECK) -C"
+ fi
+ ;;
+esac
+
+case $UNAME_MS in
+ *:IRIX*)
+ ################ SGI Irix #################
+ ##
+ ## CAUTION: always define setenv TRAP_FPE OFF on SGI before compiling
+ ##
+ FCENV="TRAP_FPE=OFF"
+ ;;
+esac
+
+echo MPIFC=\"$MPIFC\" | sed 's/\$/\\\$/g'
+echo MPILIBS=\"$MPILIBS\" | sed 's/\$/\\\$/g'
+echo FLAGS_CHECK=\"$FLAGS_CHECK\" | sed 's/\$/\\\$/g'
+echo FLAGS_NO_CHECK=\"$FLAGS_NO_CHECK\" | sed 's/\$/\\\$/g'
+echo FCENV=\"$FCENV\" | sed 's/\$/\\\$/g'
+
+# end of file
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/mpif.h (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mpif.h)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/mpif.h (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/mpif.h 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,265 @@
+! mpif.h. Generated from /opt/mpich/myrinet/intel//include/mpif.h by configure.
+
+!
+!
+! (C) 1993 by Argonne National Laboratory and Mississipi State University.
+! All rights reserved. See COPYRIGHT in top-level directory.
+!
+!
+! user include file for MPI programs, with no dependencies
+!
+! It really is not possible to make a perfect include file that can
+! be used by both F77 and F90 compilers, but this is close. We have removed
+! continuation lines (allows free form input in F90); systems whose
+! Fortran compilers support ! instead of just C or * for comments can
+! globally replace a C in the first column with !; the resulting file
+! should work for both Fortran 77 and Fortran 90.
+!
+! If your Fortran compiler supports ! for comments, you can run this
+! through sed with
+! sed -e 's/^C/\!/g'
+!
+! We have also removed the use of contractions (involving the single quote)
+! character because some users use .F instead of .f files (to invoke the
+! cpp preprocessor) and further, their preprocessor is determined to find
+! matching single quote pairs (and probably double quotes; given the
+! different rules in C and Fortran, this sounds like a disaster). Rather than
+! take the position that the poor users should get a better system, we
+! have removed the text that caused problems. Of course, the users SHOULD
+! get a better system...
+!
+! return codes
+ INTEGER MPI_SUCCESS,MPI_ERR_BUFFER,MPI_ERR_COUNT,MPI_ERR_TYPE
+ INTEGER MPI_ERR_TAG,MPI_ERR_COMM,MPI_ERR_RANK,MPI_ERR_ROOT
+ INTEGER MPI_ERR_GROUP
+ INTEGER MPI_ERR_OP,MPI_ERR_TOPOLOGY,MPI_ERR_DIMS,MPI_ERR_ARG
+ INTEGER MPI_ERR_UNKNOWN,MPI_ERR_TRUNCATE,MPI_ERR_OTHER
+ INTEGER MPI_ERR_INTERN,MPI_ERR_IN_STATUS,MPI_ERR_PENDING
+ INTEGER MPI_ERR_REQUEST, MPI_ERR_LASTCODE
+ PARAMETER (MPI_SUCCESS=0,MPI_ERR_BUFFER=1,MPI_ERR_COUNT=2)
+ PARAMETER (MPI_ERR_TYPE=3,MPI_ERR_TAG=4,MPI_ERR_COMM=5)
+ PARAMETER (MPI_ERR_RANK=6,MPI_ERR_ROOT=7,MPI_ERR_GROUP=8)
+ PARAMETER (MPI_ERR_OP=9,MPI_ERR_TOPOLOGY=10,MPI_ERR_DIMS=11)
+ PARAMETER (MPI_ERR_ARG=12,MPI_ERR_UNKNOWN=13)
+ PARAMETER (MPI_ERR_TRUNCATE=14,MPI_ERR_OTHER=15)
+ PARAMETER (MPI_ERR_INTERN=16,MPI_ERR_IN_STATUS=17)
+ PARAMETER (MPI_ERR_PENDING=18,MPI_ERR_REQUEST=19)
+ PARAMETER (MPI_ERR_LASTCODE=1073741823)
+!
+ INTEGER MPI_UNDEFINED
+ parameter (MPI_UNDEFINED = (-32766))
+!
+ INTEGER MPI_GRAPH, MPI_CART
+ PARAMETER (MPI_GRAPH = 1, MPI_CART = 2)
+ INTEGER MPI_PROC_NULL
+ PARAMETER ( MPI_PROC_NULL = (-1) )
+!
+ INTEGER MPI_BSEND_OVERHEAD
+ PARAMETER ( MPI_BSEND_OVERHEAD = 512 )
+
+ INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR
+ PARAMETER(MPI_SOURCE=2, MPI_TAG=3, MPI_ERROR=4)
+ INTEGER MPI_STATUS_SIZE
+ PARAMETER (MPI_STATUS_SIZE=4)
+ INTEGER MPI_MAX_PROCESSOR_NAME, MPI_MAX_ERROR_STRING
+ PARAMETER (MPI_MAX_PROCESSOR_NAME=256)
+ PARAMETER (MPI_MAX_ERROR_STRING=512)
+ INTEGER MPI_MAX_NAME_STRING
+ PARAMETER (MPI_MAX_NAME_STRING=63)
+ INTEGER MPI_MAX_PORT_NAME
+ PARAMETER (MPI_MAX_PORT_NAME=256)
+!
+ INTEGER MPI_COMM_NULL
+ PARAMETER (MPI_COMM_NULL=0)
+!
+ INTEGER MPI_DATATYPE_NULL
+ PARAMETER (MPI_DATATYPE_NULL = 0)
+
+ INTEGER MPI_ERRHANDLER_NULL
+ PARAMETER (MPI_ERRHANDLER_NULL = 0)
+
+ INTEGER MPI_GROUP_NULL
+ PARAMETER (MPI_GROUP_NULL = 0)
+
+ INTEGER MPI_KEYVAL_INVALID
+ PARAMETER (MPI_KEYVAL_INVALID = 0)
+
+ INTEGER MPI_REQUEST_NULL
+ PARAMETER (MPI_REQUEST_NULL = 0)
+!
+ INTEGER MPI_IDENT, MPI_CONGRUENT, MPI_SIMILAR, MPI_UNEQUAL
+ PARAMETER (MPI_IDENT=0, MPI_CONGRUENT=1, MPI_SIMILAR=2)
+ PARAMETER (MPI_UNEQUAL=3)
+!
+! MPI_BOTTOM needs to be a known address; here we put it at the
+! beginning of the common block. The point-to-point and collective
+! routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not.
+!
+! MPI_STATUS_IGNORE and MPI_STATUSES_IGNORE are similar objects
+! Until the underlying MPI library implements the C version of these
+! (a null pointer), these are declared as arrays of MPI_STATUS_SIZE
+!
+! The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL.
+! Their values are zero if they are not available. Note that
+! using these reduces the portability of code (though may enhance
+! portability between Crays and other systems)
+!
+ INTEGER MPI_TAG_UB, MPI_HOST, MPI_IO
+ INTEGER MPI_BOTTOM
+ INTEGER MPI_STATUS_IGNORE(MPI_STATUS_SIZE)
+ INTEGER MPI_STATUSES_IGNORE(MPI_STATUS_SIZE)
+ INTEGER MPI_INTEGER, MPI_REAL, MPI_DOUBLE_PRECISION
+ INTEGER MPI_COMPLEX, MPI_DOUBLE_COMPLEX,MPI_LOGICAL
+ INTEGER MPI_CHARACTER, MPI_BYTE, MPI_2INTEGER, MPI_2REAL
+ INTEGER MPI_2DOUBLE_PRECISION, MPI_2COMPLEX, MPI_2DOUBLE_COMPLEX
+ INTEGER MPI_UB, MPI_LB
+ INTEGER MPI_PACKED, MPI_WTIME_IS_GLOBAL
+ INTEGER MPI_COMM_WORLD, MPI_COMM_SELF, MPI_GROUP_EMPTY
+ INTEGER MPI_SUM, MPI_MAX, MPI_MIN, MPI_PROD, MPI_LAND, MPI_BAND
+ INTEGER MPI_LOR, MPI_BOR, MPI_LXOR, MPI_BXOR, MPI_MINLOC
+ INTEGER MPI_MAXLOC
+ INTEGER MPI_OP_NULL
+ INTEGER MPI_ERRORS_ARE_FATAL, MPI_ERRORS_RETURN
+!
+ PARAMETER (MPI_ERRORS_ARE_FATAL=119)
+ PARAMETER (MPI_ERRORS_RETURN=120)
+!
+ PARAMETER (MPI_COMPLEX=23,MPI_DOUBLE_COMPLEX=24,MPI_LOGICAL=25)
+ PARAMETER (MPI_REAL=26,MPI_DOUBLE_PRECISION=27,MPI_INTEGER=28)
+ PARAMETER (MPI_2INTEGER=29,MPI_2COMPLEX=30,MPI_2DOUBLE_COMPLEX=31)
+ PARAMETER (MPI_2REAL=32,MPI_2DOUBLE_PRECISION=33,MPI_CHARACTER=1)
+ PARAMETER (MPI_BYTE=3,MPI_UB=16,MPI_LB=15,MPI_PACKED=14)
+
+ INTEGER MPI_ORDER_C, MPI_ORDER_FORTRAN
+ PARAMETER (MPI_ORDER_C=56, MPI_ORDER_FORTRAN=57)
+ INTEGER MPI_DISTRIBUTE_BLOCK, MPI_DISTRIBUTE_CYCLIC
+ INTEGER MPI_DISTRIBUTE_NONE, MPI_DISTRIBUTE_DFLT_DARG
+ PARAMETER (MPI_DISTRIBUTE_BLOCK=121, MPI_DISTRIBUTE_CYCLIC=122)
+ PARAMETER (MPI_DISTRIBUTE_NONE=123)
+ PARAMETER (MPI_DISTRIBUTE_DFLT_DARG=-49767)
+ INTEGER MPI_MAX_INFO_KEY, MPI_MAX_INFO_VAL
+ PARAMETER (MPI_MAX_INFO_KEY=255, MPI_MAX_INFO_VAL=1024)
+ INTEGER MPI_INFO_NULL
+ PARAMETER (MPI_INFO_NULL=0)
+
+!
+! Optional Fortran Types. Configure attempts to determine these.
+!
+ INTEGER MPI_INTEGER1, MPI_INTEGER2, MPI_INTEGER4, MPI_INTEGER8
+ INTEGER MPI_INTEGER16
+ INTEGER MPI_REAL4, MPI_REAL8, MPI_REAL16
+ INTEGER MPI_COMPLEX8, MPI_COMPLEX16, MPI_COMPLEX32
+ PARAMETER (MPI_INTEGER1=1,MPI_INTEGER2=4)
+ PARAMETER (MPI_INTEGER4=6)
+ PARAMETER (MPI_INTEGER8=8)
+ PARAMETER (MPI_INTEGER16=0)
+ PARAMETER (MPI_REAL4=10)
+ PARAMETER (MPI_REAL8=11)
+ PARAMETER (MPI_REAL16=12)
+ PARAMETER (MPI_COMPLEX8=23)
+ PARAMETER (MPI_COMPLEX16=24)
+ PARAMETER (MPI_COMPLEX32=0)
+!
+! This is now handled with either the "pointer" extension or this same
+! code, appended at the end.
+! COMMON /MPIPRIV/ MPI_BOTTOM,MPI_STATUS_IGNORE,MPI_STATUSES_IGNORE
+!C
+!C Without this save, some Fortran implementations may make the common
+!C dynamic!
+!C
+!C For a Fortran90 module, we might replace /MPIPRIV/ with a simple
+!C SAVE MPI_BOTTOM
+!C
+! SAVE /MPIPRIV/
+!
+ PARAMETER (MPI_MAX=100,MPI_MIN=101,MPI_SUM=102,MPI_PROD=103)
+ PARAMETER (MPI_LAND=104,MPI_BAND=105,MPI_LOR=106,MPI_BOR=107)
+ PARAMETER (MPI_LXOR=108,MPI_BXOR=109,MPI_MINLOC=110)
+ PARAMETER (MPI_MAXLOC=111, MPI_OP_NULL=0)
+!
+ PARAMETER (MPI_GROUP_EMPTY=90,MPI_COMM_WORLD=91,MPI_COMM_SELF=92)
+ PARAMETER (MPI_TAG_UB=80,MPI_HOST=82,MPI_IO=84)
+ PARAMETER (MPI_WTIME_IS_GLOBAL=86)
+!
+ INTEGER MPI_ANY_SOURCE
+ PARAMETER (MPI_ANY_SOURCE = (-2))
+ INTEGER MPI_ANY_TAG
+ PARAMETER (MPI_ANY_TAG = (-1))
+!
+ INTEGER MPI_VERSION, MPI_SUBVERSION
+ PARAMETER (MPI_VERSION = 1, MPI_SUBVERSION = 2)
+!
+! There are additional MPI-2 constants
+ INTEGER MPI_ADDRESS_KIND, MPI_OFFSET_KIND
+ PARAMETER (MPI_ADDRESS_KIND=8)
+ PARAMETER (MPI_OFFSET_KIND=8)
+!
+! All other MPI routines are subroutines
+! This may cause some Fortran compilers to complain about defined and
+! not used. Such compilers should be improved.
+!
+! Some Fortran compilers will not link programs that contain
+! external statements to routines that are not provided, even if
+! the routine is never called. Remove PMPI_WTIME and PMPI_WTICK
+! if you have trouble with them.
+!
+ DOUBLE PRECISION MPI_WTIME, MPI_WTICK,PMPI_WTIME,PMPI_WTICK
+ EXTERNAL MPI_WTIME, MPI_WTICK,PMPI_WTIME,PMPI_WTICK
+!
+! The attribute copy/delete subroutines are symbols that can be passed
+! to MPI routines
+!
+ EXTERNAL MPI_NULL_COPY_FN, MPI_NULL_DELETE_FN, MPI_DUP_FN
+ COMMON /MPIPRIV/ MPI_BOTTOM,MPI_STATUS_IGNORE,MPI_STATUSES_IGNORE
+!
+! Without this save, some Fortran implementations may make the common
+! dynamic!
+!
+! For a Fortran90 module, we might replace /MPIPRIV/ with a simple
+! SAVE MPI_BOTTOM
+!
+ SAVE /MPIPRIV/
+!
+! $Id: mpiof.h.in,v 1.3 1999/08/06 18:33:09 thakur Exp $
+!
+! Copyright (C) 1997 University of Chicago.
+! See COPYRIGHT notice in top-level directory.
+!
+!
+! user include file for Fortran MPI-IO programs
+!
+ INTEGER MPI_MODE_RDONLY, MPI_MODE_RDWR, MPI_MODE_WRONLY
+ INTEGER MPI_MODE_DELETE_ON_CLOSE, MPI_MODE_UNIQUE_OPEN
+ INTEGER MPI_MODE_CREATE, MPI_MODE_EXCL
+ INTEGER MPI_MODE_APPEND, MPI_MODE_SEQUENTIAL
+ PARAMETER (MPI_MODE_RDONLY=2, MPI_MODE_RDWR=8, MPI_MODE_WRONLY=4)
+ PARAMETER (MPI_MODE_CREATE=1, MPI_MODE_DELETE_ON_CLOSE=16)
+ PARAMETER (MPI_MODE_UNIQUE_OPEN=32, MPI_MODE_EXCL=64)
+ PARAMETER (MPI_MODE_APPEND=128, MPI_MODE_SEQUENTIAL=256)
+!
+ INTEGER MPI_FILE_NULL
+ PARAMETER (MPI_FILE_NULL=0)
+!
+ INTEGER MPI_MAX_DATAREP_STRING
+ PARAMETER (MPI_MAX_DATAREP_STRING=128)
+!
+ INTEGER MPI_SEEK_SET, MPI_SEEK_CUR, MPI_SEEK_END
+ PARAMETER (MPI_SEEK_SET=600, MPI_SEEK_CUR=602, MPI_SEEK_END=604)
+!
+ INTEGER MPIO_REQUEST_NULL
+ PARAMETER (MPIO_REQUEST_NULL=0)
+!
+!
+!
+
+
+
+
+
+
+
+!
+!
+!
+!
+!
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/precision.h (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/precision.h)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/precision.h (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/setup/precision.h 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,38 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! precision.h. Generated from precision.h.in by configure.
+
+!
+! solver in single or double precision depending on the machine
+!
+! set to MPI_REAL to run in single precision
+! set to MPI_DOUBLE_PRECISION to run in double precision
+!
+! ALSO CHANGE FILE constants.h ACCORDINGLY
+!
+ integer, parameter :: CUSTOM_MPI_TYPE = MPI_REAL
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sort_array_coordinates.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sort_array_coordinates.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sort_array_coordinates.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,235 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! subroutines to sort MPI buffers to assemble between chunks
-
- subroutine sort_array_coordinates(npointot,x,y,z,ibool,iglob,loc,ifseg,nglob,ind,ninseg,iwork,work)
-
-! this routine MUST be in double precision to avoid sensitivity
-! to roundoff errors in the coordinates of the points
-
- implicit none
-
- include "constants.h"
-
- integer npointot,nglob
-
- integer ibool(npointot),iglob(npointot),loc(npointot)
- integer ind(npointot),ninseg(npointot)
- logical ifseg(npointot)
- double precision x(npointot),y(npointot),z(npointot)
- integer iwork(npointot)
- double precision work(npointot)
-
- integer ipoin,i,j
- integer nseg,ioff,iseg,ig
- double precision xtol
-
-! establish initial pointers
- do ipoin=1,npointot
- loc(ipoin)=ipoin
- enddo
-
-! define a tolerance, normalized radius is 1., so let's use a small value
- xtol = SMALLVALTOL
-
- ifseg(:)=.false.
-
- nseg=1
- ifseg(1)=.true.
- ninseg(1)=npointot
-
- do j=1,NDIM
-
-! sort within each segment
- ioff=1
- do iseg=1,nseg
- if(j == 1) then
-
- call rank_buffers(x(ioff),ind,ninseg(iseg))
-
- else if(j == 2) then
-
- call rank_buffers(y(ioff),ind,ninseg(iseg))
-
- else
-
- call rank_buffers(z(ioff),ind,ninseg(iseg))
-
- endif
-
- call swap_all_buffers(ibool(ioff),loc(ioff), &
- x(ioff),y(ioff),z(ioff),iwork,work,ind,ninseg(iseg))
-
- ioff=ioff+ninseg(iseg)
- enddo
-
-! check for jumps in current coordinate
- if(j == 1) then
- do i=2,npointot
- if(dabs(x(i)-x(i-1)) > xtol) ifseg(i)=.true.
- enddo
- else if(j == 2) then
- do i=2,npointot
- if(dabs(y(i)-y(i-1)) > xtol) ifseg(i)=.true.
- enddo
- else
- do i=2,npointot
- if(dabs(z(i)-z(i-1)) > xtol) ifseg(i)=.true.
- enddo
- endif
-
-! count up number of different segments
- nseg=0
- do i=1,npointot
- if(ifseg(i)) then
- nseg=nseg+1
- ninseg(nseg)=1
- else
- ninseg(nseg)=ninseg(nseg)+1
- endif
- enddo
- enddo
-
-! assign global node numbers (now sorted lexicographically)
- ig=0
- do i=1,npointot
- if(ifseg(i)) ig=ig+1
- iglob(loc(i))=ig
- enddo
-
- nglob=ig
-
- end subroutine sort_array_coordinates
-
-! -------------------- library for sorting routine ------------------
-
-! sorting routines put here in same file to allow for inlining
-
- subroutine rank_buffers(A,IND,N)
-!
-! Use Heap Sort (Numerical Recipes)
-!
- implicit none
-
- integer n
- double precision A(n)
- integer IND(n)
-
- integer i,j,l,ir,indx
- double precision q
-
- do j=1,n
- IND(j)=j
- enddo
-
- if(n == 1) return
-
- L=n/2+1
- ir=n
- 100 CONTINUE
- IF(l>1) THEN
- l=l-1
- indx=ind(l)
- q=a(indx)
- ELSE
- indx=ind(ir)
- q=a(indx)
- ind(ir)=ind(1)
- ir=ir-1
- if (ir == 1) then
- ind(1)=indx
- return
- endif
- ENDIF
- i=l
- j=l+l
- 200 CONTINUE
- IF(J <= IR) THEN
- IF(J < IR) THEN
- IF(A(IND(j)) < A(IND(j+1))) j=j+1
- ENDIF
- IF (q < A(IND(j))) THEN
- IND(I)=IND(J)
- I=J
- J=J+J
- ELSE
- J=IR+1
- ENDIF
- goto 200
- ENDIF
- IND(I)=INDX
- goto 100
- end subroutine rank_buffers
-
-! -------------------------------------------------------------------
-
- subroutine swap_all_buffers(IA,IB,A,B,C,IW,W,ind,n)
-!
-! swap arrays IA, IB, A, B and C according to addressing in array IND
-!
- implicit none
-
- integer n
-
- integer IND(n)
- integer IA(n),IB(n),IW(n)
- double precision A(n),B(n),C(n),W(n)
-
- integer i
-
- do i=1,n
- W(i)=A(i)
- IW(i)=IA(i)
- enddo
-
- do i=1,n
- A(i)=W(ind(i))
- IA(i)=IW(ind(i))
- enddo
-
- do i=1,n
- W(i)=B(i)
- IW(i)=IB(i)
- enddo
-
- do i=1,n
- B(i)=W(ind(i))
- IB(i)=IW(ind(i))
- enddo
-
- do i=1,n
- W(i)=C(i)
- enddo
-
- do i=1,n
- C(i)=W(ind(i))
- enddo
-
- end subroutine swap_all_buffers
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/specfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/specfem3D.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/specfem3D.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,2429 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 Government Sponsorship Acknowledged.
-
-!! DK DK for the merged version
- include 'call2.f90'
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
-! include values created by the mesher
- include "OUTPUT_FILES/values_from_mesher.h"
-
-!=======================================================================!
-! !
-! specfem3D is a 3-D spectral-element solver for the Earth. !
-! It uses a mesh generated by program meshfem3D !
-! !
-!=======================================================================!
-!
-! 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 caltech.edu> and/or use our online
-! bug tracking system at http://www.geodynamics.org/roundup .
-!
-! Evolution of the code:
-! ---------------------
-!
-! 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, one more doubling level
-! at the bottom of the outer core, new inflated central cube
-! with optimized shape, far fewer mesh files saved by the mesher.
-! v. 3.6 Many people, many affiliations, September 2006:
-! adjoint and kernel calculations, 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
-! 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, 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 CM5
-!
-! From Dahlen and Tromp (1998):
-! ----------------------------
-!
-! Gravity is approximated by solving eq (3.259) without the Phi_E' term
-! The ellipsoidal reference model is that of section 14.1
-! The transversely isotropic expression for PREM is that of eq (8.190)
-!
-! Formulation in the fluid (acoustic) outer core:
-! -----------------------------------------------
-!
-! In case of an acoustic medium, a displacement potential Chi is used
-! as in Chaljub and Valette, Geophysical Journal International, vol. 158,
-! p. 131-141 (2004) and *NOT* a velocity potential as in Komatitsch and Tromp,
-! Geophysical Journal International, vol. 150, p. 303-318 (2002).
-! This permits acoustic-elastic coupling based on a non-iterative time scheme.
-! Displacement if we ignore gravity is then: u = grad(Chi)
-! (In the context of the Cowling approximation displacement is
-! u = grad(rho * Chi) / rho, *not* u = grad(Chi).)
-! Velocity is then: v = grad(Chi_dot) (Chi_dot being the time derivative of Chi)
-! and pressure is: p = - rho * Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
-! The source in an acoustic element is a pressure source.
-! The potential in the outer core is called displ_outer_core for simplicity.
-! Its first time derivative is called veloc_outer_core.
-! Its second time derivative is called accel_outer_core.
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(:), pointer :: 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
-
-! 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
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: 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
- integer nspec_iso,nspec_tiso,nspec_ani
- 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, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
- integer yr,jda,ho,mi
- real(kind=CUSTOM_REAL) stf_used
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
- double precision, dimension(:,:,:) ,allocatable:: nu_source
- double precision sec,stf
- double precision, dimension(:), allocatable :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
- double precision, dimension(:), allocatable :: xi_source,eta_source,gamma_source
- double precision, dimension(:), allocatable :: t_cmt,hdur,hdur_gaussian
- double precision, dimension(:), allocatable :: theta_source,phi_source
- double precision, external :: comp_source_time_function
- double precision t0
-
-! receiver information
- integer nrec,nrec_local,nrec_tot_found,irec_local,ios
- integer, dimension(:), allocatable :: islice_selected_rec,ispec_selected_rec,number_receiver_global
- double precision, dimension(:), allocatable :: xi_receiver,eta_receiver,gamma_receiver
- double precision hlagrange
- character(len=150) :: STATIONS,rec_filename,dummystring
- double precision, dimension(:,:,:), allocatable :: nu
- double precision, allocatable, dimension(:) :: stlat,stlon,stele
- character(len=MAX_LENGTH_STATION_NAME), dimension(:), allocatable :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(:), allocatable :: 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
-
- 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 !!!!!!!!!!!!!!!!!!!!!!,iproc,iproc_read
- 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
-
-! 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
-
- 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,LOCAL_PATH,MODEL
-
-! parameters deduced from parameters read from file
- integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, 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
-
- character(len=150) prname
-
-! 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
-
-! flags to read kappa and mu and anisotropy arrays in regions where needed
- logical READ_KAPPA_MU,READ_TISO
-
-! names of the data files for all the processors in MPI
- character(len=150) outputname
-
-! if running on MareNostrum in Barcelona
- character(len=400) system_command
-
- 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_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
- logical :: CASE_3D
-
-! arrays for BCAST
- integer, dimension(38) :: 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
-
-! ************** PROGRAM STARTS HERE **************
-
-! initialize the MPI communicator and start the NPROCTOT MPI processes.
-!! DK DK suppressed for merged version call MPI_INIT(ier)
-
-! sizeprocs returns number of processes started (should be equal to NPROCTOT).
-! myrank is the rank of each process, between 0 and sizeprocs-1.
-! as usual in MPI, process 0 is in charge of coordinating everything
-! and also takes care of the main output
-!! DK DK suppressed for merged version call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
-!! DK DK suppressed for merged version call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
-
-!! DK DK added this for merged version
-! synchronize all the processes to make sure everybody has finished
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-!! 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
- allocate(buffer_send_faces(NDIM_smaller_buffers,npoin2D_max_all))
- allocate(buffer_received_faces(NDIM_smaller_buffers,npoin2D_max_all))
-
- 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,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC_computed, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB_computed, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
-
- if(err_occurred() /= 0) then
- call exit_MPI(myrank,'an error occurred while reading the parameter file')
- endif
-
-! 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/)
-
- 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(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(bcast_integer,38,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(LOCAL_PATH,150,MPI_CHARACTER,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_region_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)
-
- 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
-
-! if running on MareNostrum in Barcelona
- if(RUN_ON_MARENOSTRUM_BARCELONA) then
-
-! check that we combine the seismograms in one large file to avoid GPFS overloading
- if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) call exit_MPI(myrank,'should use SAVE_ALL_SEISMOS_IN_ONE_FILE for GPFS in Barcelona')
-
-! use the local scratch disk to save all the files, ignore the path that is given in the Par_file
- LOCAL_PATH = '/scratch/komatits_new'
-
-! add processor name to local /scratch/komatits_new path
- write(system_command,"('_proc',i4.4)") myrank
- LOCAL_PATH = trim(LOCAL_PATH) // trim(system_command)
-
- 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')
-
- 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')
-
-!! DK DK added this
- if(OCEANS) call exit_MPI(myrank,'DK DK je crois que j ai enleve les oceans par erreur, les remettre')
-
-! 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
-
-! start reading the databases
-
-! read arrays created by the mesher
-
-! crust and mantle
-
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- READ_KAPPA_MU = .false.
- READ_TISO = .false.
- nspec_iso = 1
- nspec_tiso = 1
- nspec_ani = NSPEC_CRUST_MANTLE
- else
- nspec_iso = NSPEC_CRUST_MANTLE
- if(TRANSVERSE_ISOTROPY_VAL) then
- nspec_tiso = NSPECMAX_TISO_MANTLE
- else
- nspec_tiso = 1
- endif
- nspec_ani = 1
- READ_KAPPA_MU = .true.
- READ_TISO = .true.
- endif
-
-! outer core (no anisotropy nor S velocity)
-! rmass_ocean_load is not used in this routine because it is meaningless in the outer core
- READ_KAPPA_MU = .false.
- READ_TISO = .false.
- nspec_iso = NSPEC_OUTER_CORE
- nspec_tiso = 1
- nspec_ani = 1
-
-! inner core (no anisotropy)
-! rmass_ocean_load is not used in this routine because it is meaningless in the inner core
- READ_KAPPA_MU = .true.
- READ_TISO = .false.
- nspec_iso = NSPEC_INNER_CORE
- nspec_tiso = 1
- if(ANISOTROPIC_INNER_CORE_VAL) then
- nspec_ani = NSPEC_INNER_CORE
- else
- nspec_ani = 1
- endif
-
-! 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')
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! 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)
-
-! allocate arrays for source
- allocate(islice_selected_source(NSOURCES))
- allocate(ispec_selected_source(NSOURCES))
- allocate(Mxx(NSOURCES))
- allocate(Myy(NSOURCES))
- allocate(Mzz(NSOURCES))
- allocate(Mxy(NSOURCES))
- allocate(Mxz(NSOURCES))
- allocate(Myz(NSOURCES))
- allocate(xi_source(NSOURCES))
- allocate(eta_source(NSOURCES))
- allocate(gamma_source(NSOURCES))
- allocate(t_cmt(NSOURCES))
- allocate(hdur(NSOURCES))
- allocate(hdur_gaussian(NSOURCES))
- allocate(theta_source(NSOURCES))
- allocate(phi_source(NSOURCES))
- allocate(nu_source(NDIM,NDIM,NSOURCES))
-
-! 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)
-! 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)
-
- 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')
-
-! allocate memory for receiver arrays
- allocate(islice_selected_rec(nrec))
- allocate(ispec_selected_rec(nrec))
- allocate(xi_receiver(nrec))
- allocate(eta_receiver(nrec))
- allocate(gamma_receiver(nrec))
- allocate(station_name(nrec))
- allocate(network_name(nrec))
- allocate(stlat(nrec))
- allocate(stlon(nrec))
- allocate(stele(nrec))
- allocate(nu(NDIM,NDIM,nrec))
-
-! 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)
-
-!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-! ---- source array
-
- allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ))
- 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))
- allocate(hetar_store(nrec_local,NGLLY))
- allocate(hgammar_store(nrec_local,NGLLZ))
-
-! define local to global receiver numbering mapping
- allocate(number_receiver_global(nrec_local))
- 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
-
-! synchronize all the processes before assembling the mass matrix
-! to make sure all the nodes have finished to read their databases
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-! 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))
- allocate(buffer_all_cube_from_slices(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM))
- allocate(buffer_slices(npoin2D_cube_from_slices,NDIM))
- allocate(buffer_slices2(npoin2D_cube_from_slices,NDIM))
- allocate(ibool_central_cube(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices))
-
-! 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 create_name_database(prname, myrank, IREGION_CRUST_MANTLE, LOCAL_PATH)
- call get_attenuation_model_1D(myrank, prname, 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) stop 'error while allocating seismograms'
-! 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')
- 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 *************
-! *********************************************************
-
-!! DK DK merged version: may set to 1 for timing
-! displ_crust_mantle = 1
-! veloc_crust_mantle = 1
-! displ_outer_core = 1
-! veloc_outer_core = 1
-! displ_inner_core = 1
-! veloc_inner_core = 1
-
- 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
-
- 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')
-
- 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 < 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
-
- 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
-
- 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)
- 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
-
-! if running on MareNostrum in Barcelona
- if(RUN_ON_MARENOSTRUM_BARCELONA) then
-
-! synchronize all the processes to make sure everybody has finished
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-! suppress the local directory to leave space for future runs with a different rank number
- write(system_command,"('rm -r -f /scratch/komatits_new_proc',i4.4)") myrank
- call system(system_command)
-
- endif
-
-! close the main output file
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'End of the simulation'
- write(IMAIN,*)
- close(IMAIN)
- endif
-
-! synchronize all the processes to make sure everybody has finished
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-! stop all the MPI processes, and exit
-!! DK DK suppressed this for the merged version
-! call MPI_FINALIZE(ier)
-
- end subroutine specfem3D
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/spline_routines.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/spline_routines.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/spline_routines.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,130 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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.
-!
-!=====================================================================
-
-! compute spline coefficients
-
- subroutine spline_construction(xpoint,ypoint,npoint,tangent_first_point,tangent_last_point,spline_coefficients)
-
- implicit none
-
-! tangent to the spline imposed at the first and last points
- double precision, intent(in) :: tangent_first_point,tangent_last_point
-
-! number of input points and coordinates of the input points
- integer, intent(in) :: npoint
- double precision, dimension(npoint), intent(in) :: xpoint,ypoint
-
-! spline coefficients output by the routine
- double precision, dimension(npoint), intent(out) :: spline_coefficients
-
- integer :: i
-
- double precision, dimension(:), allocatable :: temporary_array
-
- allocate(temporary_array(npoint))
-
- spline_coefficients(1) = - 1.d0 / 2.d0
-
- temporary_array(1) = (3.d0/(xpoint(2)-xpoint(1)))*((ypoint(2)-ypoint(1))/(xpoint(2)-xpoint(1))-tangent_first_point)
-
- do i = 2,npoint-1
-
- spline_coefficients(i) = ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))-1.d0) &
- / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
-
- temporary_array(i) = (6.d0*((ypoint(i+1)-ypoint(i))/(xpoint(i+1)-xpoint(i)) &
- - (ypoint(i)-ypoint(i-1))/(xpoint(i)-xpoint(i-1)))/(xpoint(i+1)-xpoint(i-1)) &
- - (xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*temporary_array(i-1)) &
- / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
-
- enddo
-
- spline_coefficients(npoint) = ((3.d0/(xpoint(npoint)-xpoint(npoint-1))) &
- * (tangent_last_point-(ypoint(npoint)-ypoint(npoint-1))/(xpoint(npoint)-xpoint(npoint-1))) &
- - 1.d0/2.d0*temporary_array(npoint-1))/(1.d0/2.d0*spline_coefficients(npoint-1)+1.d0)
-
- do i = npoint-1,1,-1
- spline_coefficients(i) = spline_coefficients(i)*spline_coefficients(i+1) + temporary_array(i)
- enddo
-
- deallocate(temporary_array)
-
- end subroutine spline_construction
-
-! --------------
-
-! evaluate a spline
-
- subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate_spline,y_spline_obtained)
-
- implicit none
-
-! number of input points and coordinates of the input points
- integer, intent(in) :: npoint
- double precision, dimension(npoint), intent(in) :: xpoint,ypoint
-
-! spline coefficients to use
- double precision, dimension(npoint), intent(in) :: spline_coefficients
-
-! abscissa at which we need to evaluate the value of the spline
- double precision, intent(in):: x_evaluate_spline
-
-! ordinate evaluated by the routine for the spline at this abscissa
- double precision, intent(out):: y_spline_obtained
-
- integer :: index_loop,index_lower,index_higher
-
- double precision :: coef1,coef2
-
-! initialize to the whole interval
- index_lower = 1
- index_higher = npoint
-
-! determine the right interval to use, by dichotomy
- do while (index_higher - index_lower > 1)
-! compute the middle of the interval
- index_loop = (index_higher + index_lower) / 2
- if(xpoint(index_loop) > x_evaluate_spline) then
- index_higher = index_loop
- else
- index_lower = index_loop
- endif
- enddo
-
-! test that the interval obtained does not have a size of zero
-! (this could happen for instance in the case of duplicates in the input list of points)
- if(xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation'
-
- coef1 = (xpoint(index_higher) - x_evaluate_spline) / (xpoint(index_higher) - xpoint(index_lower))
- coef2 = (x_evaluate_spline - xpoint(index_lower)) / (xpoint(index_higher) - xpoint(index_lower))
-
- y_spline_obtained = coef1*ypoint(index_lower) + coef2*ypoint(index_higher) + &
- ((coef1**3 - coef1)*spline_coefficients(index_lower) + &
- (coef2**3 - coef2)*spline_coefficients(index_higher))*((xpoint(index_higher) - xpoint(index_lower))**2)/6.d0
-
- end subroutine spline_evaluation
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_missing_nodes.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_missing_nodes.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_missing_nodes.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_missing_nodes.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,165 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! compute the missing nodes of a 27-node element when only the 8 corners have been given
+
+! the topology of the nodes is described in file hex_nodes.f90 as well as in
+! UTILS/chunk_notes_scanned/numbering_convention_27_nodes.*
+
+ subroutine add_missing_nodes(offset_x,offset_y,offset_z)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision, dimension(NGNOD) :: offset_x,offset_y,offset_z
+
+! list of corners defining the edges and the faces
+ integer, parameter :: NEDGES = 12, NFACES = 6
+ integer, dimension(NEDGES,2) :: list_corners_edge
+ integer, dimension(NFACES,4) :: list_corners_face
+
+ integer :: iedge,iface,ignod
+
+! list of corners defining the edges
+! the edge number is sorted according to the numbering convention defined in file hex_nodes.f90
+! as well as in DATA/util/YYYYYYYYYYYYYYYYYYYYYYYYYYY DK DK UGLY YYYYYYYYYYYYYYYYYYY
+
+ list_corners_edge( 1,1) = 1
+ list_corners_edge( 1,2) = 2
+
+ list_corners_edge( 2,1) = 2
+ list_corners_edge( 2,2) = 3
+
+ list_corners_edge( 3,1) = 3
+ list_corners_edge( 3,2) = 4
+
+ list_corners_edge( 4,1) = 4
+ list_corners_edge( 4,2) = 1
+
+ list_corners_edge( 5,1) = 1
+ list_corners_edge( 5,2) = 5
+
+ list_corners_edge( 6,1) = 2
+ list_corners_edge( 6,2) = 6
+
+ list_corners_edge( 7,1) = 3
+ list_corners_edge( 7,2) = 7
+
+ list_corners_edge( 8,1) = 4
+ list_corners_edge( 8,2) = 8
+
+ list_corners_edge( 9,1) = 5
+ list_corners_edge( 9,2) = 6
+
+ list_corners_edge(10,1) = 6
+ list_corners_edge(10,2) = 7
+
+ list_corners_edge(11,1) = 7
+ list_corners_edge(11,2) = 8
+
+ list_corners_edge(12,1) = 8
+ list_corners_edge(12,2) = 5
+
+! list of corners defining the faces
+! the face number is sorted according to the numbering convention defined in file hex_nodes.f90
+! as well as in DATA/util/YYYYYYYYYYYYYYYYYYYYYYYYYYY DK DK UGLY YYYYYYYYYYYYYYYYYYY
+
+ list_corners_face(1,1) = 1
+ list_corners_face(1,2) = 2
+ list_corners_face(1,3) = 3
+ list_corners_face(1,4) = 4
+
+ list_corners_face(2,1) = 1
+ list_corners_face(2,2) = 2
+ list_corners_face(2,3) = 6
+ list_corners_face(2,4) = 5
+
+ list_corners_face(3,1) = 2
+ list_corners_face(3,2) = 3
+ list_corners_face(3,3) = 7
+ list_corners_face(3,4) = 6
+
+ list_corners_face(4,1) = 4
+ list_corners_face(4,2) = 3
+ list_corners_face(4,3) = 7
+ list_corners_face(4,4) = 8
+
+ list_corners_face(5,1) = 1
+ list_corners_face(5,2) = 4
+ list_corners_face(5,3) = 8
+ list_corners_face(5,4) = 5
+
+ list_corners_face(6,1) = 5
+ list_corners_face(6,2) = 6
+ list_corners_face(6,3) = 7
+ list_corners_face(6,4) = 8
+
+! midside nodes (nodes located in the middle of an edge)
+ do iedge = 1,NEDGES
+
+! node numbers for edge centers start at 9
+ ignod = (iedge - 1) + 9
+
+ offset_x(ignod) = (offset_x(list_corners_edge(iedge,1)) + offset_x(list_corners_edge(iedge,2))) / 2.d0
+
+ offset_y(ignod) = (offset_y(list_corners_edge(iedge,1)) + offset_y(list_corners_edge(iedge,2))) / 2.d0
+
+ offset_z(ignod) = (offset_z(list_corners_edge(iedge,1)) + offset_z(list_corners_edge(iedge,2))) / 2.d0
+
+ enddo
+
+! side center nodes (nodes located in the middle of a face)
+ do iface = 1,NFACES
+
+! node numbers for face centers start at 21
+ ignod = (iface - 1) + 21
+
+ offset_x(ignod) = (offset_x(list_corners_face(iface,1)) + &
+ offset_x(list_corners_face(iface,2)) + &
+ offset_x(list_corners_face(iface,3)) + &
+ offset_x(list_corners_face(iface,4))) / 4.d0
+
+ offset_y(ignod) = (offset_y(list_corners_face(iface,1)) + &
+ offset_y(list_corners_face(iface,2)) + &
+ offset_y(list_corners_face(iface,3)) + &
+ offset_y(list_corners_face(iface,4))) / 4.d0
+
+ offset_z(ignod) = (offset_z(list_corners_face(iface,1)) + &
+ offset_z(list_corners_face(iface,2)) + &
+ offset_z(list_corners_face(iface,3)) + &
+ offset_z(list_corners_face(iface,4))) / 4.d0
+
+ enddo
+
+! center node (barycenter of the eight corners)
+ offset_x(27) = sum(offset_x(1:NGNOD_EIGHT_CORNERS)) / dble(NGNOD_EIGHT_CORNERS)
+ offset_y(27) = sum(offset_y(1:NGNOD_EIGHT_CORNERS)) / dble(NGNOD_EIGHT_CORNERS)
+ offset_z(27) = sum(offset_z(1:NGNOD_EIGHT_CORNERS)) / dble(NGNOD_EIGHT_CORNERS)
+
+ end subroutine add_missing_nodes
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,87 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ integer myrank
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ integer ia
+
+ double precision lat,lon,elevation,R220
+ double precision r,theta,phi,colat
+ double precision gamma
+
+! we loop on all the points of the element
+ do ia = 1,NGNOD
+
+! convert to r theta phi
+! slightly move points to avoid roundoff problem when exactly on the polar axis
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+ theta = theta + 0.0000001d0
+ phi = phi + 0.0000001d0
+ call reduce(theta,phi)
+
+! convert the geocentric colatitude to a geographic colatitude
+ colat = PI/2.0d0 - datan(1.006760466d0*dcos(theta)/dmax1(TINYVAL,dsin(theta)))
+
+! get geographic latitude and longitude in degrees
+ lat = 90.0d0 - colat*180.0d0/PI
+ lon = phi*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
+ elevation = elevation / R_EARTH
+
+! stretching topography between d220 and the surface
+ gamma = (r - R220/R_EARTH) / (R_UNIT_SPHERE - R220/R_EARTH)
+
+! add elevation to all the points of that element
+! also make sure gamma makes sense
+ if(gamma < -0.02 .or. gamma > 1.02) call exit_MPI(myrank,'incorrect value of gamma for topography')
+
+ xelm(ia) = xelm(ia)*(ONE + gamma * elevation / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * elevation / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * elevation / r)
+
+ enddo
+
+ end subroutine add_topography
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_410_650.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_410_650.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_410_650.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_410_650.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,134 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 add_topography_410_650(myrank,xelm,yelm,zelm,R220,R400,R670,R771, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,ylmcof,wk1,wk2,wk3,varstr)
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision R220,R400,R670,R771
+
+ integer ia
+
+ real(kind=4) xcolat,xlon
+ real(kind=4) topo410out,topo650out
+ double precision topo410,topo650
+
+ double precision r,theta,phi
+ double precision gamma
+
+ 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) 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=40) varstr(maxker)
+
+! we loop on all the points of the element
+ do ia = 1,NGNOD
+
+! convert to r theta phi
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+ call reduce(theta,phi)
+
+! get colatitude and longitude in degrees
+ xcolat = sngl(theta*180.0d0/PI)
+ xlon = sngl(phi*180.0d0/PI)
+
+! compute topography on 410 and 650 at current point
+ call subtopo(xcolat,xlon,topo410out,topo650out, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,ylmcof,wk1,wk2,wk3,varstr)
+
+! non-dimensionalize the topography, which is in km
+! positive for a depression, so change the sign for a perturbation in radius
+ topo410 = -dble(topo410out) / R_EARTH_KM
+ topo650 = -dble(topo650out) / R_EARTH_KM
+
+ gamma = 0.d0
+ if(r >= R400/R_EARTH .and. r <= R220/R_EARTH) then
+! stretching between R220 and R400
+ gamma = (R220/R_EARTH - r) / (R220/R_EARTH - R400/R_EARTH)
+ xelm(ia) = xelm(ia)*(ONE + gamma * topo410 / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * topo410 / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * topo410 / r)
+ elseif(r>= R771/R_EARTH .and. r <= R670/R_EARTH) then
+! stretching between R771 and R670
+ gamma = (r - R771/R_EARTH) / (R670/R_EARTH - R771/R_EARTH)
+ xelm(ia) = xelm(ia)*(ONE + gamma * topo650 / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * topo650 / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * topo650 / r)
+ elseif(r > R670/R_EARTH .and. r < R400/R_EARTH) then
+! stretching between R670 and R400
+ gamma = (R400/R_EARTH - r) / (R400/R_EARTH - R670/R_EARTH)
+ xelm(ia) = xelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
+ yelm(ia) = yelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
+ zelm(ia) = zelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
+ endif
+ if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for 410-650 topography')
+
+ enddo
+
+ end subroutine add_topography_410_650
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_cmb.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_cmb.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_cmb.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_cmb.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,84 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 add_topography_cmb(myrank,xelm,yelm,zelm,RTOPDDOUBLEPRIME,RCMB)
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision RTOPDDOUBLEPRIME,RCMB
+
+ integer ia
+
+ double precision r_start,topocmb
+
+ double precision r,theta,phi
+ double precision gamma
+
+! we loop on all the points of the element
+ do ia = 1,NGNOD
+
+! convert to r theta phi
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+ call reduce(theta,phi)
+
+! compute topography on CMB; routine subtopo_cmb needs to be supplied by the user
+! call subtopo_cmb(theta,phi,topocmb)
+ topocmb = 0.0d0
+
+! non-dimensionalize the topography, which is in km
+! positive for a depression, so change the sign for a perturbation in radius
+ topocmb = -topocmb / R_EARTH_KM
+
+! start stretching a distance RTOPDDOUBLEPRIME - RCMB below the CMB
+! and finish at RTOPDDOUBLEPRIME (D'')
+ r_start = (RCMB - (RTOPDDOUBLEPRIME - RCMB))/R_EARTH
+ gamma = 0.0d0
+ if(r >= RCMB/R_EARTH .and. r <= RTOPDDOUBLEPRIME/R_EARTH) then
+! stretching between RCMB and RTOPDDOUBLEPRIME
+ gamma = (RTOPDDOUBLEPRIME/R_EARTH - r) / (RTOPDDOUBLEPRIME/R_EARTH - RCMB/R_EARTH)
+ elseif(r>= r_start .and. r <= RCMB/R_EARTH) then
+! stretching between r_start and RCMB
+ gamma = (r - r_start) / (RCMB/R_EARTH - r_start)
+ endif
+ if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for CMB topography')
+
+ xelm(ia) = xelm(ia)*(ONE + gamma * topocmb / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * topocmb / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * topocmb / r)
+
+ enddo
+
+ end subroutine add_topography_cmb
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_icb.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_icb.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_icb.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/add_topography_icb.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,81 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 add_topography_icb(myrank,xelm,yelm,zelm,RICB,RCMB)
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision RICB,RCMB
+
+ integer ia
+
+ double precision topoicb
+
+ double precision r,theta,phi
+ double precision gamma
+
+! we loop on all the points of the element
+ do ia = 1,NGNOD
+
+! convert to r theta phi
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+ call reduce(theta,phi)
+
+! compute topography on ICB; the routine subtopo_icb needs to be supplied by the user
+! call subtopo_icb(theta,phi,topoicb)
+ topoicb = 0.0d0
+
+! non-dimensionalize the topography, which is in km
+! positive for a depression, so change the sign for a perturbation in radius
+ topoicb = -topoicb / R_EARTH_KM
+
+ gamma = 0.0d0
+ if(r > 0.0d0 .and. r <= RICB/R_EARTH) then
+! stretching between center and RICB
+ gamma = r/(RICB/R_EARTH)
+ elseif(r>= RICB/R_EARTH .and. r <= RCMB/R_EARTH) then
+! stretching between RICB and RCMB
+ gamma = (r - RCMB/R_EARTH) / (RICB/R_EARTH - RCMB/R_EARTH)
+ endif
+ if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for CMB topography')
+
+ xelm(ia) = xelm(ia)*(ONE + gamma * topoicb / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * topoicb / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * topoicb / r)
+
+ enddo
+
+ end subroutine add_topography_icb
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_after_1.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_1.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_after_1.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_after_1.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,228 @@
+
+ allocate(xstore_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(ystore_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(zstore_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(xstore_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+
+
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(ystore_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(zstore_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(xstore_inner_core(NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(ystore_inner_core(NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(zstore_inner_core(NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+!---
+
+ allocate(xix_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiy_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etax_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etay_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etaz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammax_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammay_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammaz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(xix_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiy_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiz_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etax_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etay_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etaz_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammax_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammay_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammaz_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(xix_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiy_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etax_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etay_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etaz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammax_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammay_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammaz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_after_2.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_2.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_after_2.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_after_2.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,98 @@
+
+ allocate(rmass_ocean_load(NGLOB_CRUST_MANTLE_OCEANS),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+!---
+
+ allocate(displ_crust_mantle(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(veloc_crust_mantle(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(accel_crust_mantle(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(displ_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(veloc_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(accel_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(displ_inner_core(NDIM,NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(veloc_inner_core(NDIM,NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(accel_inner_core(NDIM,NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+!---
+
+ allocate(R_memory_crust_mantle(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(R_memory_inner_core(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+!---
+
+ allocate(epsilondev_crust_mantle(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(epsilondev_inner_core(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_before.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_before.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_before.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_before.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,23 @@
+
+!! 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'
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_inner_core_model.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_inner_core_model.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_inner_core_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_inner_core_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,146 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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_aniso_inner_core_model
+
+ implicit none
+
+! one should add an MPI_BCAST in meshfem3D.f90 if one adds a read_aniso_inner_core_model subroutine
+
+ end subroutine read_aniso_inner_core_model
+
+!-----------------------------------
+
+ subroutine aniso_inner_core_model(x,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL)
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives non-dimensionalized c11,c33,c12,c13,c44
+
+ integer REFERENCE_1D_MODEL
+
+ double precision x,c11,c33,c12,c13,c44
+
+ double precision vp,vs,rho
+ double precision vp0,vs0,rho0,A0
+ double precision c66
+ double precision scale_fac
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+ vp=11.24094d0-4.09689d0*x*x
+ vs=3.56454d0-3.45241d0*x*x
+ rho=13.0885d0-8.8381d0*x*x
+
+! values at center
+ vp0=11.24094d0
+ vs0=3.56454d0
+ rho0=13.0885d0
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ vp=11.2622d0-6.3640d0*x*x
+ vs=3.6678d0-4.4475d0*x*x
+ rho=13.0885d0-8.8381d0*x*x
+
+! values at center
+ vp0=11.2622d0
+ vs0=3.6678d0
+ rho0=13.0885d0
+
+ else
+ stop 'unknown 1D reference Earth model in anisotropic inner core'
+ endif
+
+! elastic tensor for hexagonal symmetry in reduced notation:
+!
+! c11 c12 c13 0 0 0
+! c12 c11 c13 0 0 0
+! c13 c13 c33 0 0 0
+! 0 0 0 c44 0 0
+! 0 0 0 0 c44 0
+! 0 0 0 0 0 c66=(c11-c12)/2
+!
+! in terms of the A, C, L, N and F of Love (1927):
+!
+! c11 = A
+! c33 = C
+! c12 = A-2N
+! c13 = F
+! c44 = L
+! c66 = N
+!
+! isotropic equivalent:
+!
+! c11 = lambda+2mu
+! c33 = lambda+2mu
+! c12 = lambda
+! c13 = lambda
+! c44 = mu
+! c66 = mu
+
+! non-dimensionalization of elastic parameters
+ scale_fac=RHOAV*R_EARTH*R_EARTH*PI*GRAV*RHOAV
+
+! Ishii et al. (2002):
+!
+! alpha = 3.490 % = (C-A)/A0 = (c33-c11)/A0
+! beta = 0.988 % = (L-N)/A0 = (c44-c66)/A0
+! gamma = 0.881 % = (A-2N-F)/A0 = (c12-c13)/A0
+! where A0 is A at the Earth's center
+!
+! assume c11 = lamda+2mu
+! c66 = (c11-c12)/2 = mu
+!
+! then c33 = c11 + alpha*A0
+! c44 = c66 + beta*A0
+! c13 = c12 - gamma*A0
+!
+! Steinle-Neumann (2002):
+!
+! r T rho c11 c12 c13 c33 c44 KS mu
+! (km) (K) (Mg/m3) (GPa)
+! 0 5735 13.09 1693 1253 1364 1813 154 1457 184
+! 200 5729 13.08 1689 1251 1362 1809 154 1455 184
+! 400 5711 13.05 1676 1243 1353 1795 151 1444 181
+! 600 5682 13.01 1661 1232 1341 1779 150 1432 180
+! 800 5642 12.95 1638 1214 1321 1755 148 1411 178
+! 1000 5590 12.87 1606 1190 1295 1720 146 1383 175
+! 1200 5527 12.77 1559 1155 1257 1670 141 1343 169
+!
+
+ c11=rho*vp*vp*1.d9/scale_fac
+ c66=rho*vs*vs*1.d9/scale_fac
+
+ A0=rho0*vp0*vp0*1.d9/scale_fac
+ c33=c11+0.0349d0*A0
+ c44=c66+0.00988d0*A0
+ c12=c11-2.0d0*c66
+ c13=c12-0.00881d0*A0
+
+ end subroutine aniso_inner_core_model
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_mantle_model.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_mantle_model.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_mantle_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_mantle_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,864 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+!=====================================================================
+!
+! Jean-Paul Montagner, January 2002
+! modified by Min Chen, Caltech, February 2002
+!
+! input is (r, theta, phi), output is the matrix cij(6x6)
+! 0 <= r <= 1, 0 <= theta <= pi, 0 <= phi <= 2 pi
+!
+! returns non-dimensionalized cij
+!
+! creates parameters p(i=1,14,r,theta,phi)
+! from model glob-prem3sm01 globpreman3sm01 (Montagner, 2002)
+!
+!======================================================================
+
+
+ subroutine aniso_mantle_model(r,theta,phi,rho, &
+ c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,&
+ AMM_V)
+
+ implicit none
+
+ include "constants.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
+
+ double precision r,theta,phi
+ double precision rho
+ double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26, &
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
+
+ double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
+ d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
+
+ double precision colat,lon
+
+ lon = phi / DEGREES_TO_RADIANS
+ 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')
+
+! assign the local (d_ij) or global (c_ij) anisotropic parameters.
+! The c_ij are the coefficients in the global
+! reference frame used in SPECFEM3D.
+ call build_cij(AMM_V%pro,AMM_V%npar1,rho,AMM_V%beta,r,colat,lon,&
+ d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,d33,d34,d35,d36,&
+ d44,d45,d46,d55,d56,d66)
+
+ call rotate_aniso_tensor(theta,phi,d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,&
+ d33,d34,d35,d36,d44,d45,d46,d55,d56,d66,&
+ c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
+
+ end subroutine aniso_mantle_model
+
+!--------------------------------------------------------------------
+
+ subroutine build_cij(pro,npar1,rho,beta,r,theta,phi,&
+ d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,d33,d34,d35,d36,&
+ d44,d45,d46,d55,d56,d66)
+
+ implicit none
+
+ include "constants.h"
+
+ integer npar1,ndepth,idep,ipar,itheta,ilon,icz0,nx0,ny0,nz0,&
+ ict0,ict1,icp0,icp1,icz1
+
+ double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
+ d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
+ double precision r,theta,phi,rho,depth,tei,tet,ph,fi,x0,y0,pxy0
+ double precision d1,d2,d3,d4,sd,thickness,dprof1,dprof2,eps,pc1,pc2,pc3,pc4,&
+ dpr1,dpr2,param,scale_GPa,scaleval
+ double precision A,C,F,AL,AN,BC,BS,GC,GS,HC,HS,EC,ES,C1p,C1sv,C1sh,C3,S1p,S1sv,S1sh,S3
+ double precision beta(14,34,37,73),pro(47)
+ double precision anispara(14,2,4),elpar(14)
+
+ ndepth = npar1
+ pxy0 = 5.
+ x0 = 0.
+ y0 = 0.
+ nx0 = 37
+ ny0 = 73
+ nz0 = 34
+
+! avoid edge effects
+ if(theta==0.0d0) theta=0.000001d0
+ if(theta==180.d0) theta=0.999999d0*theta
+ if(phi==0.0d0) phi=0.000001d0
+ if(phi==360.d0) phi=0.999999d0*phi
+
+! 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')
+ itheta = int(theta + pxy0)/pxy0
+ ilon = int(phi + pxy0)/pxy0
+ tet = theta
+ ph = phi
+
+ icz0 = 0
+ do idep = 1,ndepth
+ if(pro(idep) > depth) icz0 = icz0 + 1
+ enddo
+
+!
+! Interpolation for depth between dep1(iz0) and dep2(iz1)
+!
+! 1 (ict0,icp0) 2 (ict0,icp1)
+! 3 (ict1,icp0) 4 (ict1,icp1)
+!
+
+ ict0 = itheta
+ ict1 = ict0 + 1
+ icp0 = ilon
+ icp1 = icp0 + 1
+ 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')
+
+ do ipar = 1,14
+ anispara(ipar,1,1) = beta(ipar,icz0,ict0,icp0)
+ anispara(ipar,2,1) = beta(ipar,icz1,ict0,icp0)
+ anispara(ipar,1,2) = beta(ipar,icz0,ict0,icp1)
+ anispara(ipar,2,2) = beta(ipar,icz1,ict0,icp1)
+ anispara(ipar,1,3) = beta(ipar,icz0,ict1,icp0)
+ anispara(ipar,2,3) = beta(ipar,icz1,ict1,icp0)
+ anispara(ipar,1,4) = beta(ipar,icz0,ict1,icp1)
+ anispara(ipar,2,4) = beta(ipar,icz1,ict1,icp1)
+ enddo
+
+!
+! calculation of distances between the selected point and grid points
+!
+ tei = pxy0*ict0 + x0 - pxy0
+ fi = pxy0*icp0 + y0 - pxy0
+
+!*** d1=de(tet,ph,tei,fi)
+
+ d1 = dsqrt(((tei - tet)**2) + ((fi - ph)**2)*(dsin((tet + tei)*DEGREES_TO_RADIANS/2.)**2))
+
+!*** d2=de(tet,ph,tei+pxy0,fi)
+
+ d2 = dsqrt(((tei - tet + pxy0)**2) + ((fi - ph)**2)*(dsin((tet + tei + pxy0)*DEGREES_TO_RADIANS/2.)**2))
+
+!*** d3=de(tet,ph,tei,fi+pxy0)
+
+ d3 = dsqrt(((tei - tet)**2) + ((fi - ph + pxy0)**2)*(dsin((tet + tei)*DEGREES_TO_RADIANS/2.)**2))
+
+!*** d4=de(tet,ph,tei+pxy0,fi+pxy0)
+
+ d4 = dsqrt(((tei - tet + pxy0)**2) + ((fi - ph + pxy0)**2)*(dsin((tet + tei + pxy0)*DEGREES_TO_RADIANS/2.)**2))
+
+ sd = d2*d3*d4 + d1*d2*d4 + d1*d3*d4 + d1*d2*d3
+ thickness = pro(icz0) - pro(icz1)
+ dprof1 = pro(icz0) - depth
+ dprof2 = depth - pro(icz1)
+ eps = 0.01
+
+ do ipar = 1,14
+ if(thickness < eps)then
+ pc1 = anispara(ipar,1,1)
+ pc2 = anispara(ipar,1,2)
+ pc3 = anispara(ipar,1,3)
+ pc4 = anispara(ipar,1,4)
+ else
+ dpr1 = dprof1/thickness
+ dpr2 = dprof2/thickness
+ pc1 = anispara(ipar,1,1)*dpr2+anispara(ipar,2,1)*dpr1
+ pc2 = anispara(ipar,1,2)*dpr2+anispara(ipar,2,2)*dpr1
+ pc3 = anispara(ipar,1,3)*dpr2+anispara(ipar,2,3)*dpr1
+ pc4 = anispara(ipar,1,4)*dpr2+anispara(ipar,2,4)*dpr1
+ endif
+ param = pc1*d2*d3*d4 + pc2*d1*d3*d4 + pc3*d1*d2*d4 + pc4*d1*d2*d3
+ param = param/sd
+ elpar(ipar) = param
+ enddo
+
+ d11 = ZERO
+ d12 = ZERO
+ d13 = ZERO
+ d14 = ZERO
+ d15 = ZERO
+ d16 = ZERO
+ d22 = ZERO
+ d23 = ZERO
+ d24 = ZERO
+ d25 = ZERO
+ d26 = ZERO
+ d33 = ZERO
+ d34 = ZERO
+ d35 = ZERO
+ d36 = ZERO
+ d44 = ZERO
+ d45 = ZERO
+ d46 = ZERO
+ d55 = ZERO
+ d56 = ZERO
+ d66 = ZERO
+!
+! create dij
+!
+ rho = elpar(1)
+ A = elpar(2)
+ C = elpar(3)
+ F = elpar(4)
+ AL = elpar(5)
+ AN = elpar(6)
+ BC = elpar(7)
+ BS = elpar(8)
+ GC = elpar(9)
+ GS = elpar(10)
+ HC = elpar(11)
+ HS = elpar(12)
+ EC = elpar(13)
+ ES = elpar(14)
+ C1p = 0.0d0
+ S1p = 0.0d0
+ C1sv = 0.0d0
+ S1sv = 0.0d0
+ C1sh = 0.0d0
+ S1sh = 0.0d0
+ C3 = 0.0d0
+ S3 = 0.0d0
+
+ d11 = A + EC + BC
+ d12 = A - 2.*AN - EC
+ d13 = F + HC
+ d14 = S3 + 2.*S1sh + 2.*S1p
+ d15 = 2.*C1p + C3
+ d16 = -BS/2. - ES
+ d22 = A + EC - BC
+ d23 = F - HC
+ d24 = 2.*S1p - S3
+ d25 = 2.*C1p - 2.*C1sh - C3
+ d26 = -BS/2. + ES
+ d33 = C
+ d34 = 2.*(S1p - S1sv)
+ d35 = 2.*(C1p - C1sv)
+ d36 = -HS
+ d44 = AL - GC
+ d45 = -GS
+ d46 = C1sh - C3
+ d55 = AL + GC
+ d56 = S3 - S1sh
+ d66 = AN - EC
+
+! non-dimensionalize the elastic coefficients using
+! the scale of GPa--[g/cm^3][(km/s)^2]
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+ scale_GPa =(RHOAV/1000.d0)*((R_EARTH*scaleval/1000.d0)**2)
+ d11 = d11/scale_GPa
+ d12 = d12/scale_GPa
+ d13 = d13/scale_GPa
+ d14 = d14/scale_GPa
+ d15 = d15/scale_GPa
+ d16 = d16/scale_GPa
+ d22 = d22/scale_GPa
+ d23 = d23/scale_GPa
+ d24 = d24/scale_GPa
+ d25 = d25/scale_GPa
+ d26 = d26/scale_GPa
+ d33 = d33/scale_GPa
+ d34 = d34/scale_GPa
+ d35 = d35/scale_GPa
+ d36 = d36/scale_GPa
+ d44 = d44/scale_GPa
+ d45 = d45/scale_GPa
+ d46 = d46/scale_GPa
+ d55 = d55/scale_GPa
+ d56 = d56/scale_GPa
+ d66 = d66/scale_GPa
+
+! non-dimensionalize
+ rho = rho*1000.d0/RHOAV
+
+ end subroutine build_cij
+
+!--------------------------------------------------------------
+
+ subroutine read_aniso_mantle_model(AMM_V)
+
+ implicit none
+
+ include "constants.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
+
+ integer nx,ny,np1,np2,ipar,ipa1,ipa,ilat,ilon,il,idep,nfin,nfi0,nf,nri
+ double precision xinf,yinf,pxy,ppp,angle,A,A2L,AL,af
+ double precision ra(47),pari(14,47)
+ double precision bet2(14,34,37,73)
+ double precision alph(73,37),ph(73,37)
+ character(len=150) glob_prem3sm01, globpreman3sm01
+
+ np1 = 1
+ np2 = 34
+ AMM_V%npar1 = (np2 - np1 + 1)
+
+!
+! glob-prem3sm01: model with rho,A,L,xi-1,1-phi,eta
+!
+ call get_value_string(glob_prem3sm01, 'model.glob_prem3sm01', 'DATA/Montagner_model/glob-prem3sm01')
+ open(19,file=glob_prem3sm01,status='old',action='read')
+
+!
+! read the models
+!
+! reference model: PREM or ACY400
+!
+ call lecmod(nri,pari,ra)
+!
+! read tomographic model (equivalent T.I. model)
+!
+ ipa = 0
+ nfi0 = 6
+ nfin = 14
+ do nf = 1,nfi0
+ ipa = ipa + 1
+ do idep = 1,AMM_V%npar1
+ il = idep + np1 - 1
+ read(19,"(2f4.0,2i3,f4.0)",end = 88) xinf,yinf,nx,ny,pxy
+
+ ppp = 1.
+ read(19,"(f5.0,f8.4)",end = 88) AMM_V%pro(idep),ppp
+
+ if(nf == 1) pari(nf,il) = ppp
+ if(nf == 2) pari(nf,il) = ppp
+ if(nf == 3) pari(nf,il) = ppp
+ if(nf == 4) ppp = pari(nf,il)
+ if(nf == 5) ppp = pari(nf,il)
+ do ilat = 1,nx
+ read(19,"(17f7.2)",end = 88) (AMM_V%beta(ipa,idep,ilat,ilon),ilon = 1,ny)
+!
+! calculation of A,C,F,L,N
+!
+! bet2(1,...)=rho, bet2(2,...)=A,bet2(3,...)=L,bet2(4,...)=xi
+! bet2(5,...)=phi=C/A, bet2(6,...)=eta=F/A-2L
+! bet2(7,...)=Bc, bet2(8,...)=Bs,bet2(9,...)=Gc,bet2(10,...)=Gs
+! bet2(11,...)=Hc, bet2(12,...)=Hs,bet2(13,...)=Ec,bet2(14,...)=Es
+!
+ do ilon = 1,ny
+ if(nf <= 3 .or. nf >= 6)then
+ bet2(ipa,idep,ilat,ilon) = AMM_V%beta(ipa,idep,ilat,ilon)*0.01*ppp + ppp
+ else
+ if(nf == 4)bet2(ipa,idep,ilat,ilon) = AMM_V%beta(ipa,idep,ilat,ilon)*0.01 + 1.
+ if(nf == 5)bet2(ipa,idep,ilat,ilon) = - AMM_V%beta(ipa,idep,ilat,ilon)*0.01 + 1.
+ endif
+ enddo
+
+ enddo
+ enddo
+ enddo
+88 close(19)
+
+!
+! read anisotropic azimuthal parameters
+!
+
+!
+! beta(ipa,idep,ilat,ilon) are sorted in (amplitude, phase)
+! normalized, in percents: 100 G/L
+!
+ call get_value_string(globpreman3sm01, 'model.globpreman3sm01', 'DATA/Montagner_model/globpreman3sm01')
+ open(unit=15,file=globpreman3sm01,status='old',action='read')
+
+ do nf = 7,nfin,2
+ ipa = nf
+ ipa1 = ipa + 1
+ do idep = 1,AMM_V%npar1
+ il = idep + np1 - 1
+ read(15,"(2f4.0,2i3,f4.0)",end = 888) xinf,yinf,nx,ny,pxy
+ read(15,"(f5.0,f8.4)",end = 888) AMM_V%pro(idep),ppp
+ if(nf == 7) ppp = pari(2,il)
+ if(nf == 9) ppp = pari(3,il)
+ af = pari(6,il)*(pari(2,il) - 2.*pari(3,il))
+ if(nf == 11) ppp = af
+ if(nf == 13) ppp = (pari(4,il) + 1.)*pari(3,il)
+
+ do ilat = 1,nx
+ read(15,"(17f7.2)",end = 888) (alph(ilon,ilat),ilon = 1,ny)
+ enddo
+
+ do ilat=1,nx
+ read(15,"(17f7.2)",end = 888) (ph(ilon,ilat),ilon = 1,ny)
+ enddo
+
+ do ilat = 1,nx
+ do ilon = 1,ny
+ angle = 2.*DEGREES_TO_RADIANS*ph(ilon,ilat)
+ AMM_V%beta(ipa,idep,ilat,ilon) = alph(ilon,ilat)*ppp*0.01d0
+ AMM_V%beta(ipa1,idep,ilat,ilon) = ph(ilon,ilat)
+ bet2(ipa,idep,ilat,ilon) = alph(ilon,ilat)*dcos(angle)*ppp*0.01d0
+ bet2(ipa1,idep,ilat,ilon) = alph(ilon,ilat)*dsin(angle)*ppp*0.01d0
+ enddo
+ enddo
+
+ enddo
+ enddo
+
+888 close(15)
+
+ do idep = 1,AMM_V%npar1
+ do ilat = 1,nx
+ do ilon = 1,ny
+
+! rho
+ AMM_V%beta(1,idep,ilat,ilon) = bet2(1,idep,ilat,ilon)
+
+! A
+ AMM_V%beta(2,idep,ilat,ilon) = bet2(2,idep,ilat,ilon)
+ A=bet2(2,idep,ilat,ilon)
+
+! C
+ AMM_V%beta(3,idep,ilat,ilon) = bet2(5,idep,ilat,ilon)*A
+
+! F
+ A2L = A - 2.*bet2(3,idep,ilat,ilon)
+ AMM_V%beta(4,idep,ilat,ilon) = bet2(6,idep,ilat,ilon)*A2L
+
+! L
+ AMM_V%beta(5,idep,ilat,ilon) = bet2(3,idep,ilat,ilon)
+ AL = bet2(3,idep,ilat,ilon)
+
+! N
+ AMM_V%beta(6,idep,ilat,ilon) = bet2(4,idep,ilat,ilon)*AL
+
+! azimuthal terms
+ do ipar = 7,14
+ AMM_V%beta(ipar,idep,ilat,ilon) = bet2(ipar,idep,ilat,ilon)
+ enddo
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine read_aniso_mantle_model
+
+!--------------------------------------------------------------------
+
+ subroutine lecmod(nri,pari,ra)
+
+ implicit none
+
+! read the reference Earth model: rho, Vph, Vsv, XI, PHI, ETA
+! array par(i,nlayer)
+! output: array pari(ipar, nlayer): rho, A, L, xi-1, phi-1, eta-1
+
+ integer i,j,k,ip,ifanis,idum1,idum2,idum3,nlayer,nout,neff,&
+ nband,nri,minlay,moho,kiti
+ double precision pari(14,47),qkappa(47),qshear(47),par(6,47)
+ double precision epa(14,47),ra(47),dcori(47),ri(47)
+ double precision corpar(21,47)
+ double precision aa,an,al,af,ac,vpv,vph,vsv,vsh,rho,red,a2l
+ character(len=80) null
+ character(len=150) Adrem119
+
+ ifanis = 1
+ nri = 47
+
+ call get_value_string(Adrem119, 'model.Adrem119', 'DATA/Montagner_model/Adrem119')
+ open(unit=13,file=Adrem119,status='old',action='read')
+ read(13,*,end = 77) nlayer,minlay,moho,nout,neff,nband,kiti,null
+
+ if(kiti == 0) read(13,"(20a4)",end = 77) idum1
+ read(13,"(20a4)",end = 77) idum2
+ read(13,"(20a4)",end = 77) idum3
+
+ do i = 1,nlayer
+ read(13,"(4x,f11.1,8d12.5)",end = 77) ra(i),(par(k,i),k = 1,6),qshear(i),qkappa(i)
+ enddo
+
+ do i = 1,nlayer
+ ri(i) = 0.001*ra(i)
+ enddo
+
+ do i = 1,nlayer
+ rho = par(1,i)
+ pari(1,i) = rho
+! A : pari(2,i)
+ pari(2,i) = rho*(par(2,i)**2)
+ aa = pari(2,i)
+! L : pari(3,i)
+ pari(3,i) = rho*(par(3,i)**2)
+ al = pari(3,i)
+! Xi : pari(4,i)= (N-L)/L
+ an = al*par(4,i)
+ pari(4,i) = 0.
+ pari(4,i) = par(4,i) - 1.
+! Phi : pari(5,i)=(a-c)/a
+ pari(5,i) = - par(5,i) + 1.
+ ac = par(5,i)*aa
+! f : pari(4,i)
+ af = par(6,i)*(aa - 2.*al)
+ pari(6,i) = par(6,i)
+ do ip = 7,14
+ pari(ip,i) = 0.
+ enddo
+ vsv = 0.
+ vsh = 0.
+ if(al < 0.0001 .or. an < 0.0001) goto 12
+ vsv = dsqrt(al/rho)
+ vsh = dsqrt(an/rho)
+ 12 vpv = dsqrt(ac/rho)
+ vph = dsqrt(aa/rho)
+ enddo
+
+ red = 1.
+ do i = 1,nlayer
+ read(13,"(15x,6e12.5,f11.1)",end = 77) (epa(j,i),j = 1,6),dcori(i)
+ epa(7,i) = epa(2,i)
+ epa(8,i) = epa(2,i)
+ epa(9,i) = epa(3,i)
+ epa(10,i) = epa(3,i)
+
+ a2l = pari(2,i) - 2.*pari(3,i)
+ epa(11,i) = epa(6,i)*a2l
+ epa(12,i) = epa(6,i)*a2l
+ epa(13,i) = epa(3,i)
+ epa(14,i) = epa(3,i)
+
+ do j = 1,14
+ epa(j,i) = red*epa(j,i)
+ enddo
+
+ read(13,"(21f7.3)",end = 77) (corpar(j,i),j = 1,21)
+
+ enddo
+
+77 close(13)
+
+ end subroutine lecmod
+
+!--------------------------------------------------------------------
+
+ subroutine rotate_aniso_tensor(theta,phi,d11,d12,d13,d14,d15,d16,&
+ d22,d23,d24,d25,d26,&
+ d33,d34,d35,d36,d44,d45,d46,d55,d56,d66,&
+ c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision theta,phi
+ double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26, &
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
+ double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
+ d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
+ double precision costheta,sintheta,cosphi,sinphi
+ double precision costhetasq,sinthetasq,cosphisq,sinphisq
+ double precision costwotheta,sintwotheta,costwophi,sintwophi
+ double precision cosfourtheta,sinfourtheta
+ double precision costhetafour,sinthetafour,cosphifour,sinphifour
+ double precision sintwophisq,sintwothetasq
+
+ costheta = dcos(theta)
+ sintheta = dsin(theta)
+ cosphi = dcos(phi)
+ sinphi = dsin(phi)
+
+ costhetasq = costheta * costheta
+ sinthetasq = sintheta * sintheta
+ cosphisq = cosphi * cosphi
+ sinphisq = sinphi * sinphi
+
+ costhetafour = costhetasq * costhetasq
+ sinthetafour = sinthetasq * sinthetasq
+ cosphifour = cosphisq * cosphisq
+ sinphifour = sinphisq * sinphisq
+
+ costwotheta = dcos(2.d0*theta)
+ sintwotheta = dsin(2.d0*theta)
+ costwophi = dcos(2.d0*phi)
+ sintwophi = dsin(2.d0*phi)
+
+ cosfourtheta = dcos(4.d0*theta)
+ sinfourtheta = dsin(4.d0*theta)
+ sintwothetasq = sintwotheta * sintwotheta
+ sintwophisq = sintwophi * sintwophi
+
+! recompute 21 anisotropic coefficients for full anisotropoc model using Mathematica
+
+c11 = d22*sinphifour - 2.*sintwophi*sinphisq*(d26*costheta + d24*sintheta) - &
+ 2.*cosphisq*sintwophi*(d16*costhetasq*costheta + &
+ (d14 + 2*d56)*costhetasq*sintheta + &
+ (d36 + 2*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
+ cosphifour*(d11*costhetafour + 2.*d15*costhetasq*sintwotheta + &
+ (d13 + 2.*d55)*sintwothetasq/2. + &
+ 2.*d35*sintwotheta*sinthetasq + d33*sinthetafour) + &
+ (sintwophisq/4.)*(d12 + d23 + 2.*(d44 + d66) + &
+ (d12 - d23 - 2.*d44 + 2.*d66)*costwotheta + &
+ 2.*(d25 + 2.*d46)*sintwotheta)
+
+c12 = -((sintwophi/2.)*sinphisq*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
+ (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
+ (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/2. + &
+ cosphisq*sintwophi*(d16*costhetasq*costheta - d24*sintheta + &
+ (d14 + 2.*d56)*costhetasq*sintheta + d34*sintheta*sinthetasq + &
+ costheta*(-d26 + (d36 + 2.*d45)*sinthetasq)) + &
+ (sintwophisq/4.)*(d22 + d11*costhetafour + &
+ 2.*d15*costhetasq*sintwotheta - 4.*d44*sinthetasq + &
+ d33*sinthetafour + costhetasq*(-4.*d66 + &
+ 2.*(d13 + 2.*d55)*sinthetasq) + &
+ costheta*(-8.*d46*sintheta + 4.*d35*sintheta*sinthetasq)) + &
+ (cosphifour + sinphifour)*(d12*costhetasq + &
+ d23*sinthetasq + d25*sintwotheta)
+
+c13 = sinphisq*(d23*costhetasq - d25*sintwotheta + d12*sinthetasq) - &
+ sintwophi*(d36*costhetasq*costheta + &
+ (d34 - 2.*d56)*costhetasq*sintheta + &
+ (d16 - 2.*d45)*costheta*sinthetasq + d14*sintheta*sinthetasq) + &
+ (cosphisq*(d11 + 6.*d13 + d33 - 4.*d55 - &
+ (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + &
+ 4.*(-d15 + d35)*sinfourtheta))/8.
+
+c14 = (-4.*cosphi*sinphisq*((-d14 - 2.*d24 + d34 + 2.*d56)*costheta + &
+ (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(-d16 + d26 + d36 + (-d16 + d36 + 2.*d45)*costwotheta)*sintheta) + &
+ 8.*cosphisq*cosphi*(d14*costhetasq*costheta - &
+ (d16 - 2.*d45)*costhetasq*sintheta + &
+ (d34 - 2.*d56)*costheta*sinthetasq - d36*sintheta*sinthetasq) + &
+ 4.*sinphi*sinphisq*(2.*d25*costwotheta + (-d12 + d23)*sintwotheta) + &
+ cosphisq*sinphi*(4.*(d15 + d35 - 4*d46)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - &
+ 2.*(d11 - d33 + 4.*d44 - 4.*d66 + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta))/8.
+
+c15 = (8.*sinphi*sinphisq*(-(d24*costheta) + d26*sintheta) + &
+ 4.*cosphi*sinphisq*(2.*(d25 + 2.*d46)*costwotheta + &
+ (-d12 + d23 + 2.*d44 - 2.*d66)*sintwotheta) + &
+ cosphisq*cosphi*(4.*(d15 + d35)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - 2.*(d11 - d33 + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta) - &
+ 2.*cosphisq*sinphi*((d14 + 3.*d34 + 2.*d56)*costheta + &
+ 3.*(d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
+ (3.*d16 + d36 + 2.*d45)*sintheta + &
+ 3.*(-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
+
+c16 = -(sinphifour*(d26*costheta + d24*sintheta)) - &
+ (3.*(sintwophisq/4.)*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
+ (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
+ (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/4. + &
+ cosphifour*(d16*costhetasq*costheta + &
+ (d14 + 2.*d56)*costhetasq*sintheta + &
+ (d36 + 2.*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
+ (sintwophi/2.)*sinphisq*(-d22 + (d12 + 2.*d66)*costhetasq + &
+ 2.*d46*sintwotheta + (d23 + 2.*d44)*sinthetasq + d25*sintwotheta) + &
+ cosphisq*(sintwophi/2.)*(d11*costhetafour + &
+ 2.*d15*costhetasq*sintwotheta - (d23 + 2.*d44)*sinthetasq + &
+ d33*sinthetafour - costhetasq*(d12 + &
+ 2.*d66 - 2.*(d13 + 2.*d55)*sinthetasq) - &
+ (d25 - d35 + 2.*d46 + d35*costwotheta)*sintwotheta)
+
+c22 = d22*cosphifour + 2.*cosphisq*sintwophi*(d26*costheta + d24*sintheta) + &
+ 2.*sintwophi*sinphisq*(d16*costhetasq*costheta + &
+ (d14 + 2.*d56)*costhetasq*sintheta + &
+ (d36 + 2.*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
+ sinphifour*(d11*costhetafour + 2.*d15*costhetasq*sintwotheta + &
+ (d13 + 2.*d55)*sintwothetasq/2. + &
+ 2.*d35*sintwotheta*sinthetasq + d33*sinthetafour) + &
+ (sintwophisq/4.)*(d12 + d23 + 2.*(d44 + d66) + &
+ (d12 - d23 - 2.*d44 + 2.*d66)*costwotheta + &
+ 2.*(d25 + 2.*d46)*sintwotheta)
+
+c23 = d13*costhetafour*sinphisq + &
+ sintheta*sinthetasq*(d14*sintwophi + d13*sinphisq*sintheta) + &
+ costheta*sinthetasq*((d16 - 2.*d45)*sintwophi + &
+ 2.*(d15 - d35)*sinphisq*sintheta) + &
+ costhetasq*costheta*(d36*sintwophi + &
+ 2.*(-d15 + d35)*sinphisq*sintheta) + &
+ costhetasq*sintheta*((d34 - 2.*d56)*sintwophi + &
+ (d11 + d33 - 4.*d55)*sinphisq*sintheta) + &
+ cosphisq*(d23*costhetasq - d25*sintwotheta + d12*sinthetasq)
+
+c24 = (8.*cosphisq*cosphi*(d24*costheta - d26*sintheta) + &
+ 4.*cosphisq*sinphi*(2.*(d25 + 2.*d46)*costwotheta + &
+ (-d12 + d23 + 2.*d44 - 2.*d66)*sintwotheta) + &
+ sinphi*sinphisq*(4.*(d15 + d35)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - &
+ 2.*(d11 - d33 + (d11 - 2.*d13 + &
+ d33 - 4.*d55)*costwotheta)*sintwotheta) + &
+ 2.*cosphi*sinphisq*((d14 + 3.*d34 + 2.*d56)*costheta + &
+ 3.*(d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
+ (3.*d16 + d36 + 2.*d45)*sintheta + &
+ 3.*(-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
+
+c25 = (4.*cosphisq*sinphi*((-d14 - 2.*d24 + d34 + 2.*d56)*costheta + &
+ (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(-d16 + d26 + d36 + (-d16 + d36 + 2.*d45)*costwotheta)*sintheta) - &
+ 8.*sinphi*sinphisq*(d14*costhetasq*costheta - &
+ (d16 - 2.*d45)*costhetasq*sintheta + &
+ (d34 - 2.*d56)*costheta*sinthetasq - d36*sintheta*sinthetasq) + &
+ 4.*cosphisq*cosphi*(2.*d25*costwotheta + (-d12 + d23)*sintwotheta) + &
+ cosphi*sinphisq*(4.*(d15 + d35 - 4.*d46)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - 2.*(d11 - d33 + 4.*d44 - 4.*d66 + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta))/8.
+
+c26 = cosphifour*(d26*costheta + d24*sintheta) + &
+ (3.*(sintwophisq/4.)*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
+ (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
+ (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/4. - &
+ sinphifour*(d16*costhetasq*costheta + &
+ (d14 + 2.*d56)*costhetasq*sintheta + &
+ (d36 + 2.*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
+ cosphisq*(sintwophi/2.)*(-d22 + (d12 + 2.*d66)*costhetasq + &
+ 2.*d46*sintwotheta + (d23 + 2.*d44)*sinthetasq + &
+ d25*sintwotheta) + (sintwophi/2.)*sinphisq*(d11*costhetafour + &
+ 2.*d15*costhetasq*sintwotheta - (d23 + 2.*d44)*sinthetasq + &
+ d33*sinthetafour - costhetasq*(d12 + &
+ 2.*d66 - 2.*(d13 + 2.*d55)*sinthetasq) - &
+ (d25 - d35 + 2.*d46 + d35*costwotheta)*sintwotheta)
+
+c33 = d33*costhetafour - 2.*d35*costhetasq*sintwotheta + &
+ (d13 + 2.*d55)*sintwothetasq/2. - &
+ 2.*d15*sintwotheta*sinthetasq + d11*sinthetafour
+
+c34 = cosphi*(d34*costhetasq*costheta - (d36 + 2.*d45)*costhetasq*sintheta + &
+ (d14 + 2.*d56)*costheta*sinthetasq - d16*sintheta*sinthetasq) + &
+ (sinphi*(4.*(d15 + d35)*costwotheta + 4.*(-d15 + d35)*cosfourtheta + &
+ 2.*(-d11 + d33)*sintwotheta + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*sinfourtheta))/8.
+
+c35 = sinphi*(-(d34*costhetasq*costheta) + &
+ (d36 + 2.*d45)*costhetasq*sintheta - &
+ (d14 + 2.*d56)*costheta*sinthetasq + d16*sintheta*sinthetasq) + &
+ (cosphi*(4.*(d15 + d35)*costwotheta + 4.*(-d15 + d35)*cosfourtheta + &
+ 2.*(-d11 + d33)*sintwotheta + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*sinfourtheta))/8.
+
+c36 = (4.*costwophi*((d16 + 3.*d36 - 2.*d45)*costheta + &
+ (-d16 + d36 + 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
+ (3.*d14 + d34 - 2.*d56)*sintheta + &
+ (-d14 + d34 - 2.*d56)*(-4.*sinthetasq*sintheta + 3.*sintheta)) + &
+ sintwophi*(d11 - 4.*d12 + 6.*d13 - 4.*d23 + d33 - 4.*d55 + &
+ 4.*(d12 - d23)*costwotheta - &
+ (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + &
+ 8.*d25*sintwotheta + 4.*(-d15 + d35)*sinfourtheta))/16.
+
+c44 = (d11 - 2.*d13 + d33 + 4.*(d44 + d55 + d66) - &
+ (d11 - 2.*d13 + d33 - 4.*(d44 - d55 + d66))*costwophi + &
+ 4.*sintwophi*((d16 - d36 + 2.*d45)*costheta + &
+ (-d16 + d36 + 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) - &
+ 2.*(d14 - d34 + (d14 - d34 + 2.*d56)*costwotheta)*sintheta) + &
+ 8.*cosphisq*((d44 - d66)*costwotheta - 2.*d46*sintwotheta) + &
+ 2.*sinphisq*(-((d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta) + &
+ 4.*(-d15 + d35)*sinfourtheta))/16.
+
+c45 = (4.*costwophi*((d16 - d36 + 2.*d45)*costheta + &
+ (-d16 + d36 + 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) - &
+ 2.*(d14 - d34 + (d14 - d34 + 2.*d56)*costwotheta)*sintheta) + &
+ sintwophi*(d11 - 2.*d13 + d33 - 4.*(d44 - d55 + d66) + &
+ 4.*(-d44 + d66)*costwotheta - &
+ (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + 8.*d46*sintwotheta + &
+ 4.*(-d15 + d35)*sinfourtheta))/16.
+
+c46 = (-2.*sinphi*sinphisq*((-d14 + d34 + 2.*d56)*costheta + &
+ (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(-d16 + d36 + (-d16 + d36 + 2.*d45)*costwotheta)*sintheta) + &
+ 4.*cosphisq*cosphi*(2.*d46*costwotheta + (d44 - d66)*sintwotheta) + &
+ cosphi*sinphisq*(4.*(d15 - 2.*d25 + d35 - 2.*d46)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - &
+ 2.*(d11 - 2.*d12 + 2.*d23 - d33 + 2.*d44 - 2.*d66 + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta) + &
+ 4.*cosphisq*sinphi*((d14 - 2.*d24 + d34)*costheta + &
+ (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
+ (d16 - 2.*d26 + d36)*sintheta + &
+ (-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
+
+c55 = d66*sinphisq*sinthetasq + (sintwotheta/2.)*(-2.*d46*sinphisq + &
+ (d36 + d45)*sintwophi*sintheta) + &
+ costhetasq*(d44*sinphisq + (d14 + d56)*sintwophi*sintheta) - &
+ sintwophi*(d45*costhetasq*costheta + d34*costhetasq*sintheta + &
+ d16*costheta*sinthetasq + d56*sintheta*sinthetasq) + &
+ (cosphisq*(d11 - 2.*d13 + d33 + 4.*d55 - &
+ (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + &
+ 4.*(-d15 + d35)*sinfourtheta))/8.
+
+c56 = (8.*cosphisq*cosphi*(d56*costhetasq*costheta - &
+ (d16 - d36 - d45)*costhetasq*sintheta - &
+ (d14 - d34 + d56)*costheta*sinthetasq - d45*sintheta*sinthetasq) + &
+ 4.*sinphi*sinphisq*(2.*d46*costwotheta + (d44 - d66)*sintwotheta) + &
+ cosphisq*sinphi*(4.*(d15 - 2.*d25 + d35 - 2.*d46)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - &
+ 2.*(d11 - 2.*d12 + 2.*d23 - d33 + 2.*d44 - 2.*d66 + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta) - &
+ 4.*cosphi*sinphisq*((d14 - 2.*d24 + d34)*costheta + &
+ (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
+ (d16 - 2.*d26 + d36)*sintheta + &
+ (-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
+
+c66 = -((sintwophi/2.)*sinphisq*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
+ (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
+ (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/2. + &
+ cosphisq*sintwophi*(d16*costhetasq*costheta - d24*sintheta + &
+ (d14 + 2.*d56)*costhetasq*sintheta + d34*sintheta*sinthetasq + &
+ costheta*(-d26 + (d36 + 2.*d45)*sinthetasq)) + &
+ (sintwophisq/4.)*(d22 + d11*costhetafour + &
+ 2.*d15*costhetasq*sintwotheta - 2.*(d23 + d44)*sinthetasq + &
+ d33*sinthetafour - 2.*sintwotheta*(d25 + d46 - d35*sinthetasq) - &
+ 2.*costhetasq*(d12 + d66 - (d13 + 2.*d55)*sinthetasq)) + &
+ (cosphifour + sinphifour)*(d66*costhetasq + &
+ d44*sinthetasq + d46*sintwotheta)
+
+
+end subroutine rotate_aniso_tensor
+!--------------------------------------------------------------------
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_central_cube.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,261 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,437 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,742 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 "OUTPUT_FILES/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 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,1904 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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>.
+! <savage13 at gps.caltech.edu>
+! <savage13 at dtm.ciw.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(:), pointer :: 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
+
+ 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(:)
+ end if
+
+ 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(:)
+ end do
+
+end subroutine attenuation_model_setup
+
+subroutine attenuation_save_arrays(prname, 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(:), pointer :: 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
+ character(len=150) prname
+ integer ier
+ integer myrank
+ integer, save :: first_time_called = 1
+
+ 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=prname(1:len_trim(prname))//'1D_Q.bin',status='unknown',form='unformatted')
+ 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(:), pointer :: 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(:), pointer :: 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
+
+ allocate(AM_V%Qtau_s(N_SLS))
+
+ 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, prname, 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(:), pointer :: 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
+ character(len=150) prname
+ 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
+
+ if(myrank == 0 .AND. iregion_code == IREGION_CRUST_MANTLE .AND. first_time_called == 1) then
+ first_time_called = 0
+ open(unit=27, file=prname(1:len_trim(prname))//'1D_Q.bin', status='unknown', form='unformatted')
+ 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)
+
+ call MPI_BARRIER(MPI_COMM_WORLD, ier)
+
+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(:), pointer :: 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(:), pointer :: 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, prname, one_minus_sum_beta, factor_common, scale_factor, tau_s, vnspec)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer myrank, vnspec
+ character(len=150) prname
+ 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
+
+ open(unit=27, file=prname(1:len_trim(prname))//'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, prnt, 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
+! write(*,*)j,tau_s(j),tau_e(j)
+ 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)
+ end do
+! write(*,*)A(i),B(i),10**f(i)
+ 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 copied from Matlab fminsearch.m
+! and modified to suit my nefarious 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)
+! prnt = Input
+! 3 => report every iteration
+! 4 => report every iteration, total simplex
+! err = Output
+! 0 => Normal exeecution, converged within desired range
+! 1 => Function Evaluation exceeded limit
+! 2 => Iterations exceeded limit
+!
+! See Matlab fminsearch
+subroutine fminsearch(funk, x, n, itercount, tolf, prnt, 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, prnt, 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
+ if(prnt == 3) then
+ write(*,*)'Iterations Funk Evals Value How'
+ write(*,*)itercount, func_evals, fv(1), how
+ endif
+ if(prnt == 4) then
+ write(*,*)'How: ',how
+ write(*,*)'V: ', v
+ write(*,*)'fv: ',fv
+ write(*,*)'evals: ',func_evals
+ endif
+
+ do while (func_evals < maxfun .AND. itercount < maxiter)
+
+ if(max_size_simplex(v,n) <= tolx .AND. &
+ max_value(fv,n+1) <= tolf) then
+ goto 666
+ 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
+ if (prnt == 3) then
+ write(*,*)itercount, func_evals, fv(1), how
+ elseif (prnt == 4) then
+ write(*,*)
+ write(*,*)'How: ',how
+ write(*,*)'v: ',v
+ write(*,*)'fv: ',fv
+ write(*,*)'evals: ',func_evals
+ endif
+ enddo
+
+ if(func_evals > maxfun) then
+ write(*,*)'function evaluations exceeded prescribed limit', maxfun
+ err = 1
+ endif
+ if(itercount > maxiter) then
+ write(*,*)'iterations exceeded prescribed limit', maxiter
+ err = 2
+ endif
+
+666 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
+ end do
+ 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
+ write(*,*)'iflag:',iflag
+ call exit_MPI_without_rank('Invalid idoubling flag in attenuation_model_1D_prem from get_model()')
+ endif
+
+end subroutine attenuation_model_1D_PREM
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/auto_ner.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/auto_ner.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/auto_ner.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/auto_ner.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,500 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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>.
+! <savage13 at gps.caltech.edu>
+! <savage13 at dtm.ciw.edu>
+!
+! It is based partially upon formulation in:
+!
+! @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}}
+!
+! and the core determination was developed.
+!
+
+ subroutine auto_time_stepping(WIDTH, NEX_MAX, DT)
+ implicit none
+
+ include 'constants.h'
+
+ integer NEX_MAX
+ double precision DT, WIDTH
+ double precision RADIAL_LEN_RATIO_CENTRAL_CUBE
+ double precision RADIUS_INNER_CORE
+ double precision DOUBLING_INNER_CORE
+ double precision P_VELOCITY_MAX ! Located Near the inner Core Boundary
+ double precision MAXIMUM_STABILITY_CONDITION
+ double precision MIN_GLL_POINT_SPACING_5
+
+ RADIAL_LEN_RATIO_CENTRAL_CUBE = 0.40d0
+ MAXIMUM_STABILITY_CONDITION = 0.40d0
+ RADIUS_INNER_CORE = 1221.0d0
+ DOUBLING_INNER_CORE = 8.0d0
+ P_VELOCITY_MAX = 11.02827d0
+ MIN_GLL_POINT_SPACING_5 = 0.1730d0
+
+ DT = ( RADIAL_LEN_RATIO_CENTRAL_CUBE * ((WIDTH * (PI / 180.0d0)) * RADIUS_INNER_CORE) / &
+ ( dble(NEX_MAX) / DOUBLING_INNER_CORE ) / P_VELOCITY_MAX) * &
+ MIN_GLL_POINT_SPACING_5 * MAXIMUM_STABILITY_CONDITION
+
+ end subroutine auto_time_stepping
+
+ subroutine auto_attenuation_periods(WIDTH, NEX_MAX, MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
+ implicit none
+
+ include 'constants.h'
+
+ integer NEX_MAX, MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD
+ double precision WIDTH, TMP
+ double precision GLL_SPACING, PTS_PER_WAVELENGTH
+ double precision S_VELOCITY_MIN, DEG2KM
+ double precision THETA(5)
+
+ GLL_SPACING = 4.00d0
+ PTS_PER_WAVELENGTH = 4.00d0
+ S_VELOCITY_MIN = 2.25d0
+ DEG2KM = 111.00d0
+
+ ! THETA defines the width of the Attenation Range in Decades
+ ! The number defined here were determined by minimizing
+ ! the "flatness" of the absoption spectrum. Each THETA
+ ! is defined for a particular N_SLS (constants.h)
+ ! THETA(2) is for N_SLS = 2
+ THETA(1) = 0.00d0
+ THETA(2) = 0.75d0
+ THETA(3) = 1.75d0
+ THETA(4) = 2.25d0
+ THETA(5) = 2.85d0
+
+ ! Compute Min Attenuation Period
+ !
+ ! The Minimum attenuation period = (Grid Spacing in km) / V_min
+ ! Grid spacing in km = Width of an element in km * spacing for GLL point * points per wavelength
+ ! Width of element in km = (Angular width in degrees / NEX_MAX) * degrees to km
+
+ TMP = (WIDTH / ( GLL_SPACING * dble(NEX_MAX)) * DEG2KM * PTS_PER_WAVELENGTH ) / &
+ S_VELOCITY_MIN
+ 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')
+ endif
+
+ ! Compute Max Attenuation Period
+ !
+ ! The max attenuation period for 3 SLS is optimally
+ ! 1.75 decades from the min attenuation period, see THETA above
+ TMP = TMP * 10.0d0**THETA(N_SLS)
+ MAX_ATTENUATION_PERIOD = TMP
+
+ end subroutine auto_attenuation_periods
+
+ subroutine auto_ner(WIDTH, 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)
+
+ implicit none
+
+ include 'constants.h'
+
+ double precision WIDTH
+ integer NEX_MAX
+ integer NER_CRUST, NER_80_MOHO, NER_220_80, NER_400_220, NER_600_400, &
+ NER_670_600, NER_771_670, NER_TOPDDOUBLEPRIME_771, &
+ NER_CMB_TOPDDOUBLEPRIME, NER_OUTER_CORE, NER_TOP_CENTRAL_CUBE_ICB
+ double precision R_CENTRAL_CUBE
+ logical CASE_3D
+
+ integer, parameter :: NUM_REGIONS = 14
+ integer, dimension(NUM_REGIONS) :: scaling
+ double precision, dimension(NUM_REGIONS) :: radius
+ double precision, dimension(NUM_REGIONS-1) :: ratio_top
+ double precision, dimension(NUM_REGIONS-1) :: ratio_bottom
+ integer, dimension(NUM_REGIONS-1) :: NER
+ integer NEX_ETA
+
+ ! This is PREM in Kilometers, well ... kinda, not really ....
+ radius(1) = 6371.00d0 ! Surface
+ radius(2) = 6346.60d0 ! Moho - 1st Mesh Doubling Interface
+ radius(3) = 6291.60d0 ! 80
+ radius(4) = 6151.00d0 ! 220
+ radius(5) = 5971.00d0 ! 400
+ radius(6) = 5771.00d0 ! 600
+ radius(7) = 5701.00d0 ! 670
+ radius(8) = 5600.00d0 ! 771
+ radius(9) = 4712.00d0 ! 1650 - 2nd Mesh Doubling: Geochemical Layering; Kellogg et al. 1999, Science
+ radius(10) = 3630.00d0 ! D''
+ radius(11) = 3480.00d0 ! CMB
+ radius(12) = 2511.00d0 ! 3860 - 3rd Mesh Doubling Interface
+ radius(13) = 1371.00d0 ! 5000 - 4th Mesh Doubling Interface
+ radius(14) = 982.00d0 ! Top Central Cube
+
+ call find_r_central_cube(NEX_MAX, radius(14), NEX_ETA)
+
+ ! Mesh Doubling
+ scaling(1) = 1 ! SURFACE TO MOHO
+ scaling(2:8) = 2 ! MOHO TO G'' (Geochemical Mantle 1650)
+ scaling(9:11) = 4 ! G'' TO MIC (Middle Inner Core)
+ scaling(12) = 8 ! MIC TO MIC-II
+ scaling(13:14) = 16 ! MIC-II TO Central Cube -> Center of the Earth
+
+ ! Minimum Number of Elements a Region must have
+ NER(:) = 1
+ NER(3:5) = 2
+ if(CASE_3D) then
+ NER(1) = 2
+ endif
+
+ ! Find the Number of Radial Elements in a region based upon
+ ! the aspect ratio of the elements
+ call auto_optimal_ner(NUM_REGIONS, WIDTH, NEX_MAX, radius, scaling, NER, ratio_top, ratio_bottom)
+
+ ! Set Output arguments
+ NER_CRUST = NER(1)
+ NER_80_MOHO = NER(2)
+ NER_220_80 = NER(3)
+ NER_400_220 = NER(4)
+ NER_600_400 = NER(5)
+ NER_670_600 = NER(6)
+ NER_771_670 = NER(7)
+ NER_TOPDDOUBLEPRIME_771 = NER(8) + NER(9)
+ NER_CMB_TOPDDOUBLEPRIME = NER(10)
+ NER_OUTER_CORE = NER(11) + NER(12)
+ NER_TOP_CENTRAL_CUBE_ICB = NER(13)
+ R_CENTRAL_CUBE = radius(14) * 1000.0d0
+
+ end subroutine auto_ner
+
+ subroutine auto_optimal_ner(NUM_REGIONS, width, NEX, r, scaling, NER, rt, rb)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer NUM_REGIONS
+ integer NEX
+ double precision width ! Width of the Chunk in Degrees
+ integer, dimension(NUM_REGIONS-1) :: NER ! Elements per Region - IN-N-OUT - Yummy !
+ integer, dimension(NUM_REGIONS) :: scaling ! Element Doubling - INPUT
+ double precision, dimension(NUM_REGIONS) :: r ! Radius - INPUT
+ double precision, dimension(NUM_REGIONS-1) :: rt ! Ratio at Top - OUTPUT
+ double precision, dimension(NUM_REGIONS-1) :: rb ! Ratio at Bottom - OUTPUT
+
+ double precision dr, w, ratio, xi, ximin, wt, wb
+ integer ner_test
+ integer i
+
+ ! Find optimal elements per region
+ do i = 1,NUM_REGIONS-1
+ dr = r(i) - r(i+1) ! Radial Length of Ragion
+ wt = width * PI/180.0d0 * r(i) / (NEX*1.0d0 / scaling(i)*1.0d0) ! Element Width Top
+ wb = width * PI/180.0d0 * r(i+1) / (NEX*1.0d0 / scaling(i)*1.0d0) ! Element Width Bottom
+ w = (wt + wb) * 0.5d0 ! Average Width of Region
+ ner_test = NER(i) ! Initial solution
+ ratio = (dr / ner_test) / w ! Aspect Ratio of Element
+ xi = dabs(ratio - 1.0d0) ! Aspect Ratio should be near 1.0
+ ximin = 1e7 ! Initial Minimum
+
+ do while(xi <= ximin)
+ NER(i) = ner_test ! Found a better solution
+ ximin = xi !
+ ner_test = ner_test + 1 ! Increment ner_test and
+ ratio = (dr / ner_test) / w ! look for a better
+ xi = dabs(ratio - 1.0d0) ! solution
+ end do
+ rt(i) = dr / NER(i) / wt ! Find the Ratio of Top
+ rb(i) = dr / NER(i) / wb ! and Bottom for completeness
+ end do
+
+ end subroutine auto_optimal_ner
+
+ subroutine find_r_central_cube(nex_xi_in, rcube, nex_eta_in)
+ implicit none
+
+ integer, parameter :: NBNODE = 8
+ double precision, parameter :: alpha = 0.41d0
+
+ integer npts
+ integer nex_xi, nex_eta_in, nex_xi_in
+ integer nex_eta
+ double precision rcube, rcubestep, rcube_test, rcubemax
+ double precision xi, ximin
+ double precision , allocatable, dimension(:,:) :: points
+ double precision elem(NBNODE+1, 2)
+ integer nspec_cube, nspec_chunks, ispec, nspec
+ double precision edgemax, edgemin
+ double precision max_edgemax, min_edgemin
+ double precision aspect_ratio, max_aspect_ratio
+
+ nex_xi = nex_xi_in / 16
+
+
+ rcubestep = 1.0d0
+ rcube_test = 930.0d0
+ rcubemax = 1100.0d0
+ nex_eta_in = -1
+ ximin = 1e7
+ rcube = rcube_test
+
+ do while(rcube_test <= rcubemax)
+ max_edgemax = -1e7
+ min_edgemin = 1e7
+ max_aspect_ratio = 0.0d0
+ call compute_nex(nex_xi, rcube_test, alpha, nex_eta)
+ npts = (4 * nex_xi * nex_eta * NBNODE) + (nex_xi * nex_xi * NBNODE)
+ allocate(points(npts, 2))
+ call compute_IC_mesh(rcube_test, points, npts, nspec_cube, nspec_chunks, nex_xi, nex_eta)
+ nspec = nspec_cube + nspec_chunks
+ do ispec = 1,nspec
+ call get_element(points, ispec, npts, elem)
+ call get_size_min_max(elem, edgemax, edgemin)
+ aspect_ratio = edgemax / edgemin
+ max_edgemax = MAX(max_edgemax, edgemax)
+ min_edgemin = MIN(min_edgemin, edgemin)
+ max_aspect_ratio = MAX(max_aspect_ratio, aspect_ratio)
+ end do
+ xi = (max_edgemax / min_edgemin)
+! xi = abs(rcube_test - 981.0d0) / 45.0d0
+! write(*,'(a,5(f14.4,2x))')'rcube, xi, ximin:-',rcube_test, xi, min_edgemin,max_edgemax,max_aspect_ratio
+ deallocate(points)
+ if(xi < ximin) then
+ ximin = xi
+ rcube = rcube_test
+ nex_eta_in = nex_eta
+ endif
+ rcube_test = rcube_test + rcubestep
+ enddo
+
+ end subroutine find_r_central_cube
+
+ subroutine compute_nex(nex_xi, rcube, alpha, ner)
+ implicit none
+
+ double precision, parameter :: RICB_KM = 1221.0d0
+ double precision, parameter :: PI = 3.1415
+
+ integer nex_xi, ner
+ double precision rcube, alpha
+ integer ix
+ double precision ratio_x, factx, xi
+ double precision x, y
+ double precision surfx, surfy
+ double precision dist_cc_icb, somme, dist_moy
+
+ somme = 0.0d0
+
+ do ix = 0,nex_xi/2,1
+ ratio_x = (ix * 1.0d0) / ( nex_xi * 1.0d0)
+ factx = 2.0d0 * ratio_x - 1.0d0
+ xi = (PI / 2.0d0) * factx
+ x = (rcube / sqrt(2.0d0)) * factx
+ y = (rcube / sqrt(2.0d0)) * (1 + cos(xi) * alpha / (PI / 2.0d0))
+
+ surfx = RICB_KM * cos(3 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
+ surfy = RICB_KM * sin(3 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
+
+ dist_cc_icb = sqrt((surfx -x)**2 + (surfy - y)**2)
+ if(ix /= nex_xi/2) then
+ dist_cc_icb = dist_cc_icb * 2
+ endif
+ somme = somme + dist_cc_icb
+ end do
+ dist_moy = somme / (nex_xi + 1)
+ ner = nint(dist_moy / ((PI * RICB_KM) / (2*nex_xi)))
+ end subroutine compute_nex
+
+ subroutine get_element(points, ispec, npts, pts)
+ implicit none
+ integer npts, ispec
+ integer, parameter :: NBNODE = 8
+ double precision pts(NBNODE+1,2), points(npts,2)
+ pts(1:8,:) = points( ( (ispec-1) * NBNODE)+1 : ( (ispec) * NBNODE )+1, : )
+ pts(NBNODE+1,:) = pts(1,:) ! Use first point as the last point
+ end subroutine get_element
+
+ subroutine get_size_min_max(pts, edgemax, edgemin)
+ implicit none
+ integer ie, ix1,ix2,ix3
+ integer, parameter :: NBNODE = 8
+ double precision edgemax, edgemin, edge
+ double precision pts(NBNODE+1, 2)
+
+
+ edgemax = -1e7
+ edgemin = -edgemax
+ do ie = 1,NBNODE/2,1
+ ix1 = (ie * 2) - 1
+ ix2 = ix1 + 1
+ ix3 = ix1 + 2
+ edge = sqrt( (pts(ix1,1) - pts(ix2,1))**2 + (pts(ix1,2) - pts(ix2,2))**2 ) + &
+ sqrt( (pts(ix2,1) - pts(ix3,1))**2 + (pts(ix2,2) - pts(ix3,2))**2 )
+ edgemax = MAX(edgemax, edge)
+ edgemin = MIN(edgemin, edge)
+ end do
+ end subroutine get_size_min_max
+
+ subroutine compute_IC_mesh(rcube, points, npts, nspec_cube, nspec_chunks, nex_xi, nex_eta)
+ implicit none
+
+ integer, parameter :: NBNODE = 8
+ integer npts
+ integer nspec_chunks, nspec_cube
+
+ double precision rcube
+ double precision alpha
+ double precision points(npts, 2)
+ double precision x, y
+
+ integer nex_eta, nex_xi
+ integer ic, ix, iy, in
+ integer, parameter, dimension(NBNODE) :: iaddx(NBNODE) = (/0,1,2,2,2,1,0,0/)
+ integer, parameter, dimension(NBNODE) :: iaddy(NBNODE) = (/0,0,0,1,2,2,2,1/)
+ integer k
+
+ k = 1
+ alpha = 0.41d0
+ nspec_chunks = 0
+ do ic = 0,3
+ do ix = 0,(nex_xi-1)*2,2
+ do iy = 0,(nex_eta-1)*2,2
+ do in = 1,NBNODE
+ call compute_coordinate(ix+iaddx(in), iy+iaddy(in), nex_xi*2, nex_eta*2, rcube, ic, alpha, x,y)
+ points(k,1) = x
+ points(k,2) = y
+ k = k + 1
+ end do
+ nspec_chunks = nspec_chunks + 1
+ end do
+ end do
+ end do
+
+ nspec_cube = 0
+ do ix = 0,(nex_xi-1)*2,2
+ do iy = 0,(nex_xi-1)*2,2
+ do in = 1,NBNODE
+ call compute_coordinate_central_cube(ix+iaddx(in), iy+iaddy(in), nex_xi*2, nex_xi*2, rcube, alpha,x,y)
+ points(k,1) = x
+ points(k,2) = y
+ k = k + 1
+ end do
+ nspec_cube = nspec_cube + 1
+ end do
+ end do
+
+ end subroutine compute_IC_mesh
+
+ subroutine compute_coordinate_central_cube(ix,iy,nbx,nby,radius, alpha, x, y)
+ implicit none
+
+ double precision, parameter :: PI = 3.1415d0
+
+ integer ix, iy, nbx, nby
+ double precision radius, alpha
+ double precision x, y
+
+ double precision ratio_x, ratio_y
+ double precision factx, facty
+ double precision xi, eta
+
+ ratio_x = (ix * 1.0d0) / (nbx * 1.0d0)
+ ratio_y = (iy * 1.0d0) / (nby * 1.0d0)
+
+ factx = 2.0d0 * ratio_x - 1.0d0
+ facty = 2.0d0 * ratio_y - 1.0d0
+
+ xi = (PI / 2.0d0) * factx
+ eta = (PI / 2.0d0) * facty
+
+ x = (radius / sqrt(2.0d0)) * factx * ( 1 + cos(eta) * alpha / (PI / 2.0d0))
+ y = (radius / sqrt(2.0d0)) * facty * ( 1 + cos(xi) * alpha / (PI / 2.0d0))
+
+ end subroutine compute_coordinate_central_cube
+
+ subroutine compute_coordinate(ix,iy,nbx, nby, rcube, ic, alpha, x, y)
+ implicit none
+
+ double precision, parameter :: PI = 3.1415d0
+ double precision, parameter :: RICB_KM = 1221.0d0
+
+ integer ix, iy, nbx, nby, ic
+ double precision rcube, alpha
+ double precision x, y
+
+ double precision ratio_x, ratio_y
+ double precision factx, xi
+ double precision xcc, ycc
+ double precision xsurf, ysurf
+ double precision deltax, deltay
+ double precision temp
+
+ ratio_x = (ix * 1.0d0) / (nbx * 1.0d0)
+ ratio_y = (iy * 1.0d0) / (nby * 1.0d0)
+
+ factx = 2.0d0 * ratio_x - 1.0d0
+ xi = (PI/2.0d0) * factx
+
+ xcc = (rcube / sqrt(2.0d0)) * factx
+ ycc = (rcube / sqrt(2.0d0)) * (1 + cos(xi) * alpha / (PI/2.0d0))
+
+ xsurf = RICB_KM * cos(3.0d0 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
+ ysurf = RICB_KM * sin(3.0d0 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
+
+ deltax = xsurf - xcc
+ deltay = ysurf - ycc
+
+ x = xsurf - ratio_y * deltax
+ y = ysurf - ratio_y * deltay
+
+ if(ic == 1) then
+ temp = x
+ x = y
+ y = temp
+ else if (ic == 2) then
+ x = -x
+ y = -y
+ else if (ic == 3) then
+ temp = x
+ x = -y
+ y = temp
+ end if
+ end subroutine compute_coordinate
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/calc_jacobian.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/calc_jacobian.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/calc_jacobian.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/calc_jacobian.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,145 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 calc_jacobian(myrank,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore, &
+ xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec,nspec,myrank
+
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+ double precision dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+!! 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
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer i,j,k,ia
+
+ double precision xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
+ double precision xmesh,ymesh,zmesh
+ double precision xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ double precision jacobian
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ xxi = ZERO
+ xeta = ZERO
+ xgamma = ZERO
+ yxi = ZERO
+ yeta = ZERO
+ ygamma = ZERO
+ zxi = ZERO
+ zeta = ZERO
+ zgamma = ZERO
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+
+ do ia=1,NGNOD
+ xxi = xxi + dershape3D(1,ia,i,j,k)*xelm(ia)
+ xeta = xeta + dershape3D(2,ia,i,j,k)*xelm(ia)
+ xgamma = xgamma + dershape3D(3,ia,i,j,k)*xelm(ia)
+ yxi = yxi + dershape3D(1,ia,i,j,k)*yelm(ia)
+ yeta = yeta + dershape3D(2,ia,i,j,k)*yelm(ia)
+ ygamma = ygamma + dershape3D(3,ia,i,j,k)*yelm(ia)
+ zxi = zxi + dershape3D(1,ia,i,j,k)*zelm(ia)
+ zeta = zeta + dershape3D(2,ia,i,j,k)*zelm(ia)
+ zgamma = zgamma + dershape3D(3,ia,i,j,k)*zelm(ia)
+ xmesh = xmesh + shape3D(ia,i,j,k)*xelm(ia)
+ ymesh = ymesh + shape3D(ia,i,j,k)*yelm(ia)
+ zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
+ enddo
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+ xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
+
+ if(jacobian <= ZERO) call exit_MPI(myrank,'3D Jacobian undefined')
+
+! invert the relation (Fletcher p. 50 vol. 2)
+ xix = (yeta*zgamma-ygamma*zeta) / jacobian
+ xiy = (xgamma*zeta-xeta*zgamma) / jacobian
+ xiz = (xeta*ygamma-xgamma*yeta) / jacobian
+ etax = (ygamma*zxi-yxi*zgamma) / jacobian
+ etay = (xxi*zgamma-xgamma*zxi) / jacobian
+ etaz = (xgamma*yxi-xxi*ygamma) / jacobian
+ gammax = (yxi*zeta-yeta*zxi) / jacobian
+ gammay = (xeta*zxi-xxi*zeta) / jacobian
+ gammaz = (xxi*yeta-xeta*yxi) / jacobian
+
+! save the derivatives and the jacobian
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ xixstore(i,j,k) = sngl(xix)
+ xiystore(i,j,k) = sngl(xiy)
+ xizstore(i,j,k) = sngl(xiz)
+ etaxstore(i,j,k) = sngl(etax)
+ etaystore(i,j,k) = sngl(etay)
+ etazstore(i,j,k) = sngl(etaz)
+ gammaxstore(i,j,k) = sngl(gammax)
+ gammaystore(i,j,k) = sngl(gammay)
+ gammazstore(i,j,k) = sngl(gammaz)
+ else
+ xixstore(i,j,k) = xix
+ xiystore(i,j,k) = xiy
+ xizstore(i,j,k) = xiz
+ etaxstore(i,j,k) = etax
+ etaystore(i,j,k) = etay
+ etazstore(i,j,k) = etaz
+ gammaxstore(i,j,k) = gammax
+ gammaystore(i,j,k) = gammay
+ gammazstore(i,j,k) = gammaz
+ endif
+
+! store mesh coordinates
+ xstore(i,j,k,ispec) = xmesh
+ ystore(i,j,k,ispec) = ymesh
+ zstore(i,j,k,ispec) = zmesh
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine calc_jacobian
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call1.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call1.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call1.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call1.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,45 @@
+
+!! DK DK created this for merged version
+
+ call specfem3D( &
+!! DK DK to do later, for attenuation only; not done yet by lack of time
+ omsb_crust_mantle_dble,factor_scale_crust_mantle_dble, omsb_inner_core_dble,factor_scale_inner_core_dble, &
+ one_minus_sum_beta_crust_mantle,factor_scale_crust_mantle, one_minus_sum_beta_inner_core,factor_scale_inner_core, &
+ factor_common_crust_mantle,factor_common_inner_core,factor_common_crust_mantle_dble, factor_common_inner_core_dble, &
+!! DK DK to do later, for oceans only
+ rmass_ocean_load, &
+!! DK DK already computed
+ myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo, &
+ 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, &
+!! DK DK recomputed after the end of the mesher and before the beginning of the solver
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+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, &
+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, &
+ 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, &
+!! DK DK do not need to be initialized
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
+ displ_outer_core,veloc_outer_core,accel_outer_core,displ_inner_core,veloc_inner_core,accel_inner_core, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
+R_memory_crust_mantle, epsilondev_crust_mantle, R_memory_inner_core, epsilondev_inner_core)
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call2.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call2.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call2.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call2.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,45 @@
+
+!! DK DK created this for merged version
+
+ subroutine specfem3D( &
+!! DK DK to do later, for attenuation only; not done yet by lack of time
+ omsb_crust_mantle_dble,factor_scale_crust_mantle_dble, omsb_inner_core_dble,factor_scale_inner_core_dble, &
+ one_minus_sum_beta_crust_mantle,factor_scale_crust_mantle, one_minus_sum_beta_inner_core,factor_scale_inner_core, &
+ factor_common_crust_mantle,factor_common_inner_core,factor_common_crust_mantle_dble, factor_common_inner_core_dble, &
+!! DK DK to do later, for oceans only
+ rmass_ocean_load, &
+!! DK DK already computed
+ myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo, &
+ 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, &
+!! DK DK recomputed after the end of the mesher and before the beginning of the solver
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+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, &
+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, &
+ 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, &
+!! DK DK do not need to be initialized
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
+ displ_outer_core,veloc_outer_core,accel_outer_core,displ_inner_core,veloc_inner_core,accel_inner_core, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
+R_memory_crust_mantle, epsilondev_crust_mantle, R_memory_inner_core, epsilondev_inner_core)
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_mass_matrix_one_element.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_mass_matrix_one_element.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_mass_matrix_one_element.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_mass_matrix_one_element.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,80 @@
+
+!! DK DK added this for merged version
+
+ if(ipass == 2) then
+
+! suppress fictitious elements in central cube
+! also take into account the fact that array idoubling is not allocated for the outer core
+ add_contrib_this_element = .true.
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) add_contrib_this_element = .false.
+ endif
+
+ if(add_contrib_this_element) then
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+
+!! DK DK changed this for merged version
+! if(PERFORM_CUTHILL_MCKEE) then
+! iglobnum = ibool(i,j,k,invperm(ispec))
+! iglobnum = ibool(i,j,k,perm(ispec))
+! else
+ iglobnum = ibool(i,j,k,ispec)
+! endif
+
+! compute the jacobian
+ 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))
+
+! definition depends if region is fluid or solid
+ if(iregion_code == IREGION_CRUST_MANTLE .or. iregion_code == IREGION_INNER_CORE) then
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglobnum) = rmass(iglobnum) + &
+ sngl(dble(rhostore_local(i,j,k)) * dble(jacobianl) * weight)
+ else
+ rmass(iglobnum) = rmass(iglobnum) + rhostore_local(i,j,k) * jacobianl * weight
+ endif
+
+! fluid in outer core
+ else if(iregion_code == IREGION_OUTER_CORE) then
+
+! no anisotropy in the fluid, use kappav
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglobnum) = rmass(iglobnum) + &
+ sngl(dble(jacobianl) * weight * dble(rhostore_local(i,j,k)) / dble(kappavstore_local(i,j,k)))
+ else
+ rmass(iglobnum) = rmass(iglobnum) + &
+ jacobianl * weight * rhostore_local(i,j,k) / kappavstore_local(i,j,k)
+ endif
+
+ else
+ call exit_MPI(myrank,'wrong region code')
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ endif ! of exclusion of fictitious inner core elements
+
+ endif ! of ipass == 2
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_source_spectrum.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_spectrum.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_source_spectrum.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_source_spectrum.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,39 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+ double precision function comp_source_spectrum(om,hdur)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision om,hdur
+
+ comp_source_spectrum = dexp(-0.25d0*(om*hdur/SOURCE_DECAY_MIMIC_TRIANGLE)**2)
+
+ end function comp_source_spectrum
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_source_time_function.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_time_function.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_source_time_function.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/comp_source_time_function.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,42 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+ double precision function comp_source_time_function(t,hdur)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision t,hdur
+
+ double precision, external :: netlib_specfun_erf
+
+! quasi Heaviside
+ comp_source_time_function = 0.5d0*(1.0d0 + netlib_specfun_erf(t/hdur))
+
+ end function comp_source_time_function
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_arrays_source.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_arrays_source.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_arrays_source.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_arrays_source.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,331 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 compute_arrays_source(ispec_selected_source, &
+ xi_source,eta_source,gamma_source,sourcearray, &
+ Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ xigll,yigll,zigll,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec_selected_source,nspec
+
+ double precision xi_source,eta_source,gamma_source
+ double precision Mxx,Myy,Mzz,Mxy,Mxz,Myz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xix,xiy,xiz,etax,etay,etaz, &
+ gammax,gammay,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+
+ double precision xixd,xiyd,xizd,etaxd,etayd,etazd,gammaxd,gammayd,gammazd
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+! source arrays
+ double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: G11,G12,G13,G21,G22,G23,G31,G32,G33
+ double precision, dimension(NGLLX) :: hxis,hpxis
+ double precision, dimension(NGLLY) :: hetas,hpetas
+ double precision, dimension(NGLLZ) :: hgammas,hpgammas
+
+ integer k,l,m
+
+! calculate G_ij for general source location
+! the source does not necessarily correspond to a Gauss-Lobatto point
+ do m=1,NGLLZ
+ do l=1,NGLLY
+ do k=1,NGLLX
+
+ xixd = dble(xix(k,l,m,ispec_selected_source))
+ xiyd = dble(xiy(k,l,m,ispec_selected_source))
+ xizd = dble(xiz(k,l,m,ispec_selected_source))
+ etaxd = dble(etax(k,l,m,ispec_selected_source))
+ etayd = dble(etay(k,l,m,ispec_selected_source))
+ etazd = dble(etaz(k,l,m,ispec_selected_source))
+ gammaxd = dble(gammax(k,l,m,ispec_selected_source))
+ gammayd = dble(gammay(k,l,m,ispec_selected_source))
+ gammazd = dble(gammaz(k,l,m,ispec_selected_source))
+
+ G11(k,l,m) = Mxx*xixd+Mxy*xiyd+Mxz*xizd
+ G12(k,l,m) = Mxx*etaxd+Mxy*etayd+Mxz*etazd
+ G13(k,l,m) = Mxx*gammaxd+Mxy*gammayd+Mxz*gammazd
+ G21(k,l,m) = Mxy*xixd+Myy*xiyd+Myz*xizd
+ G22(k,l,m) = Mxy*etaxd+Myy*etayd+Myz*etazd
+ G23(k,l,m) = Mxy*gammaxd+Myy*gammayd+Myz*gammazd
+ G31(k,l,m) = Mxz*xixd+Myz*xiyd+Mzz*xizd
+ G32(k,l,m) = Mxz*etaxd+Myz*etayd+Mzz*etazd
+ G33(k,l,m) = Mxz*gammaxd+Myz*gammayd+Mzz*gammazd
+
+ enddo
+ enddo
+ enddo
+
+! compute Lagrange polynomials at the source location
+ call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
+ call lagrange_any(eta_source,NGLLY,yigll,hetas,hpetas)
+ call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
+
+! calculate source array
+ do m=1,NGLLZ
+ do l=1,NGLLY
+ do k=1,NGLLX
+ call multiply_arrays_source(sourcearrayd,G11,G12,G13,G21,G22,G23, &
+ G31,G32,G33,hxis,hpxis,hetas,hpetas,hgammas,hpgammas,k,l,m)
+ enddo
+ enddo
+ enddo
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ sourcearray(:,:,:,:) = sngl(sourcearrayd(:,:,:,:))
+ else
+ sourcearray(:,:,:,:) = sourcearrayd(:,:,:,:)
+ endif
+
+ end subroutine compute_arrays_source
+
+!================================================================
+
+! we put these multiplications in a separate routine because otherwise
+! some compilers try to unroll the six loops above and take forever to compile
+ subroutine multiply_arrays_source(sourcearrayd,G11,G12,G13,G21,G22,G23, &
+ G31,G32,G33,hxis,hpxis,hetas,hpetas,hgammas,hpgammas,k,l,m)
+
+ implicit none
+
+ include "constants.h"
+
+! source arrays
+ double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: G11,G12,G13,G21,G22,G23,G31,G32,G33
+ double precision, dimension(NGLLX) :: hxis,hpxis
+ double precision, dimension(NGLLY) :: hetas,hpetas
+ double precision, dimension(NGLLZ) :: hgammas,hpgammas
+
+ integer k,l,m
+
+ integer ir,it,iv
+
+ sourcearrayd(:,k,l,m) = ZERO
+
+ do iv=1,NGLLZ
+ do it=1,NGLLY
+ do ir=1,NGLLX
+
+ sourcearrayd(1,k,l,m) = sourcearrayd(1,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
+ *(G11(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
+ +G12(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
+ +G13(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
+
+ sourcearrayd(2,k,l,m) = sourcearrayd(2,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
+ *(G21(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
+ +G22(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
+ +G23(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
+
+ sourcearrayd(3,k,l,m) = sourcearrayd(3,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
+ *(G31(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
+ +G32(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
+ +G33(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine multiply_arrays_source
+
+!================================================================
+
+subroutine compute_arrays_adjoint_source(myrank, adj_source_file, &
+ xi_receiver,eta_receiver,gamma_receiver, nu,adj_sourcearray, &
+ xigll,yigll,zigll,NSTEP)
+
+ implicit none
+
+ include 'constants.h'
+
+! input
+ integer myrank, NSTEP
+
+ double precision xi_receiver, eta_receiver, gamma_receiver
+
+ character(len=*) adj_source_file
+
+! output
+ real(kind=CUSTOM_REAL) :: adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ)
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ double precision, dimension(NDIM,NDIM) :: nu
+
+ double precision scale_displ
+
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
+ hgammar(NGLLZ), hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL) :: adj_src(NSTEP,NDIM),adj_src_u(NSTEP,NDIM)
+
+ integer icomp, itime, i, j, k, ios
+ double precision :: junk
+ character(len=3) :: comp(NDIM)
+ character(len=150) :: filename
+
+ scale_displ = R_EARTH
+
+ call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
+
+ adj_sourcearray(:,:,:,:,:) = 0.
+
+ comp = (/"LHN", "LHE", "LHZ"/)
+
+ do icomp = 1, NDIM
+
+ filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit = IIN, file = trim(filename), iostat = ios)
+ if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//' does not exist')
+ do itime = 1, NSTEP
+ read(IIN,*) junk, adj_src(itime,icomp)
+ enddo
+ close(IIN)
+
+ enddo
+
+ adj_src = adj_src/scale_displ
+
+ do itime = 1, NSTEP
+ adj_src_u(itime,:) = nu(1,:) * adj_src(itime,1) + nu(2,:) * adj_src(itime,2) + nu(3,:) * adj_src(itime,3)
+ enddo
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ adj_sourcearray(:,:,i,j,k) = hxir(i) * hetar(j) * hgammar(k) * adj_src_u(:,:)
+ enddo
+ enddo
+ enddo
+
+
+end subroutine compute_arrays_adjoint_source
+
+!================================================================
+
+subroutine comp_subarrays_adjoint_src(myrank, adj_source_file, &
+ xi_receiver,eta_receiver,gamma_receiver, nu,adj_sourcearray, &
+ xigll,yigll,zigll,NSTEP,iadjsrc,it_sub_adj,NSTEP_SUB_ADJ, &
+ NTSTEP_BETWEEN_READ_ADJSRC)
+
+ implicit none
+
+ include 'constants.h'
+
+! input -- notice here NSTEP is different from the NSTEP in the main program
+! instead NSTEP = iadjsrc_len(it_sub_adj), the length of this specific block
+ integer myrank, NSTEP
+
+ double precision xi_receiver, eta_receiver, gamma_receiver
+
+ character(len=*) adj_source_file
+
+! Vala added
+ integer it_sub_adj,NSTEP_SUB_ADJ,NTSTEP_BETWEEN_READ_ADJSRC
+ integer, dimension(NSTEP_SUB_ADJ,2) :: iadjsrc
+
+! output
+ real(kind=CUSTOM_REAL) :: adj_sourcearray(NTSTEP_BETWEEN_READ_ADJSRC,NDIM,NGLLX,NGLLY,NGLLZ)
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ double precision, dimension(NDIM,NDIM) :: nu
+
+ double precision scale_displ
+
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
+ hgammar(NGLLZ), hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL) :: adj_src(NSTEP,NDIM),adj_src_u(NSTEP,NDIM)
+
+ integer icomp, itime, i, j, k, ios
+ double precision :: junk
+ character(len=3) :: comp(NDIM)
+ character(len=150) :: filename
+
+ scale_displ = R_EARTH
+
+ call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
+
+ adj_sourcearray(:,:,:,:,:) = 0.
+
+ comp = (/"LHN", "LHE", "LHZ"/)
+
+ do icomp = 1, NDIM
+
+ filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit = IIN, file = trim(filename), iostat = ios)
+ if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//'does not exist')
+ do itime =1,iadjsrc(it_sub_adj,1)-1
+ read(IIN,*) junk,junk
+ enddo
+ do itime = iadjsrc(it_sub_adj,1), iadjsrc(it_sub_adj,1)+NSTEP-1
+ read(IIN,*) junk, adj_src(itime-iadjsrc(it_sub_adj,1)+1,icomp)
+ enddo
+ close(IIN)
+
+ enddo
+
+ adj_src = adj_src/scale_displ
+
+ do itime = 1, NSTEP
+ adj_src_u(itime,:) = nu(1,:) * adj_src(itime,1) + nu(2,:) * adj_src(itime,2) + nu(3,:) * adj_src(itime,3)
+ enddo
+
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ adj_sourcearray(1:NSTEP,:,i,j,k) = hxir(i) * hetar(j) * hgammar(k) * adj_src_u(:,:)
+ enddo
+ enddo
+ enddo
+
+
+end subroutine comp_subarrays_adjoint_src
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_coordinates_grid.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_coordinates_grid.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_coordinates_grid.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_coordinates_grid.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,327 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 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,r_bottom,ner,ilayer,ichunk,rotation_matrix,NCHUNKS,&
+ INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm,offset_x,offset_y,offset_z
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+ integer, intent(in) :: iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA, &
+ NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ner,ilayer,ichunk,NCHUNKS
+
+ double precision :: ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,r_top,r_bottom
+
+ logical :: INCLUDE_CENTRAL_CUBE
+ integer :: NUMBER_OF_MESH_LAYERS
+
+! local variables
+ integer :: i,j,ignod
+
+ double precision :: xi,eta,gamma,x,y,x_,y_,z,rgb,rgt,rn
+ double precision :: x_bot,y_bot,z_bot
+ double precision :: x_top,y_top,z_top
+
+ double precision, dimension(NDIM) :: vector_ori,vector_rotated
+
+ double precision :: ratio_xi, ratio_eta, fact_xi, fact_eta, &
+ fact_xi_,fact_eta_
+
+ double precision, parameter :: PI_OVER_TWO = PI / 2.d0
+
+
+! this to avoid compilation warnings
+ x_=0
+ y_=0
+
+! loop on all the nodes in this element
+ do ignod = 1,NGNOD
+
+ if(ilayer == NUMBER_OF_MESH_LAYERS .and. INCLUDE_CENTRAL_CUBE) then
+! case of the inner core
+ ratio_xi = ((iproc_xi + offset_x(ignod)/dble(NEX_PER_PROC_XI))/dble(NPROC_XI))
+ fact_xi = 2.d0*ratio_xi-1.d0
+
+ ratio_eta = ((iproc_eta + offset_y(ignod)/dble(NEX_PER_PROC_ETA))/dble(NPROC_ETA))
+ fact_eta = 2.d0*ratio_eta-1.d0
+
+ fact_xi_ = tan((ANGULAR_WIDTH_XI_RAD/2.d0) * fact_xi)
+ fact_eta_ = tan((ANGULAR_WIDTH_ETA_RAD/2.d0) * fact_eta)
+
+! uncomment the following lines to have more regular surface mesh (better aspect ratio for each element)
+! uncomment the corresponding lines in the else condition of this if statement too.
+! note that the ratio bigger_edge_size/smaller_edge_size for the surface mesh is a bit higher (1.43 vs 1.41)
+
+! fact_xi_= (3.d0*fact_xi+4.d0*fact_xi_)/7.d0
+! fact_eta_= (3.d0*fact_eta+4.d0*fact_eta_)/7.d0
+
+ xi = PI_OVER_TWO*fact_xi
+ eta = PI_OVER_TWO*fact_eta
+
+ gamma = ONE / sqrt(ONE + fact_xi_**2 + fact_eta_**2)
+ rgt = (r_top / R_EARTH)*gamma
+
+! coordinates of the edge extremity on the central cube surface
+ x_bot = ((r_bottom / R_EARTH) / sqrt(3.d0))* fact_xi * (1 + cos(eta)*CENTRAL_CUBE_INFLATE_FACTOR / PI)
+ y_bot = ((r_bottom / R_EARTH) / sqrt(3.d0)) * fact_eta * (1 + cos(xi)*CENTRAL_CUBE_INFLATE_FACTOR / PI)
+ z_bot = ((r_bottom / R_EARTH) / sqrt(3.d0)) * (1 + (cos(xi) + cos(eta))*CENTRAL_CUBE_INFLATE_FACTOR / PI)
+
+! coordinates of the edge extremity on the ICB
+ x_top = fact_xi_*rgt
+ y_top = fact_eta_*rgt
+ z_top = rgt
+
+ rn = offset_z(ignod) / dble(ner)
+ x = x_top*rn + x_bot*(ONE-rn)
+ y = y_top*rn + y_bot*(ONE-rn)
+ z = z_top*rn + z_bot*(ONE-rn)
+
+ select case (ichunk)
+ case(CHUNK_AB)
+ xelm(ignod) = -y
+ yelm(ignod) = x
+ zelm(ignod) = z
+ case(CHUNK_AB_ANTIPODE)
+ xelm(ignod) = -y
+ yelm(ignod) = -x
+ zelm(ignod) = -z
+ case(CHUNK_AC)
+ xelm(ignod) = -y
+ yelm(ignod) = -z
+ zelm(ignod) = x
+ case(CHUNK_AC_ANTIPODE)
+ xelm(ignod) = -y
+ yelm(ignod) = z
+ zelm(ignod) = -x
+ case(CHUNK_BC)
+ xelm(ignod) = -z
+ yelm(ignod) = y
+ zelm(ignod) = x
+ case(CHUNK_BC_ANTIPODE)
+ xelm(ignod) = z
+ yelm(ignod) = -y
+ zelm(ignod) = x
+ case default
+ stop 'incorrect chunk number in compute_coord_main_mesh'
+ end select
+! write(IMAIN,*) x,' ',y,' ',z
+ else
+
+! uncomment the following lines to have more regular surface mesh (better aspect ratio for each element)
+! note that the ratio bigger_edge_size/smaller_edge_size for the surface mesh is a bit higher (1.43 vs 1.41)
+! ratio_xi = ((iproc_xi + offset_x(ignod)/dble(NEX_PER_PROC_XI))/dble(NPROC_XI))*tan(ANGULAR_WIDTH_XI_RAD/2.d0)
+! x_ = 2.d0*ratio_xi-tan(ANGULAR_WIDTH_XI_RAD/2.d0)
+! ratio_eta = ((iproc_eta + offset_y(ignod)/dble(NEX_PER_PROC_ETA))/dble(NPROC_ETA))*tan(ANGULAR_WIDTH_ETA_RAD/2.d0)
+! y_ = 2.d0*ratio_eta-tan(ANGULAR_WIDTH_ETA_RAD/2.d0)
+
+ ratio_xi = ((iproc_xi + offset_x(ignod)/dble(NEX_PER_PROC_XI))/dble(NPROC_XI))
+ x = 2.d0*ratio_xi-1
+
+ ratio_eta = ((iproc_eta + offset_y(ignod)/dble(NEX_PER_PROC_ETA))/dble(NPROC_ETA))
+ y = 2.d0*ratio_eta-1
+
+ x = tan((ANGULAR_WIDTH_XI_RAD/2.d0) * x)
+ y = tan((ANGULAR_WIDTH_ETA_RAD/2.d0) * y)
+
+! uncomment the following lines to have more regular surface mesh (better aspect ratio for each element)
+! note that the ratio bigger_edge_size/smaller_edge_size for the surface mesh is a bit higher (1.43 vs 1.41)
+! x= (3.d0*x_+4.d0*x)/7.d0
+! y= (3.d0*y_+4.d0*y)/7.d0
+
+ gamma = ONE / sqrt(ONE + x*x + y*y)
+
+ rgt = (r_top / R_EARTH)*gamma
+ rgb = (r_bottom / R_EARTH)*gamma
+
+ ! define the mesh points on the top and the bottom in the six regions of the cubed shpere
+ select case (ichunk)
+
+ case(CHUNK_AB)
+
+ x_top = -y*rgt
+ y_top = x*rgt
+ z_top = rgt
+
+ x_bot = -y*rgb
+ y_bot = x*rgb
+ z_bot = rgb
+
+ case(CHUNK_AB_ANTIPODE)
+
+ x_top = -y*rgt
+ y_top = -x*rgt
+ z_top = -rgt
+
+ x_bot = -y*rgb
+ y_bot = -x*rgb
+ z_bot = -rgb
+
+ case(CHUNK_AC)
+
+ x_top = -y*rgt
+ y_top = -rgt
+ z_top = x*rgt
+
+ x_bot = -y*rgb
+ y_bot = -rgb
+ z_bot = x*rgb
+
+ case(CHUNK_AC_ANTIPODE)
+
+ x_top = -y*rgt
+ y_top = rgt
+ z_top = -x*rgt
+
+ x_bot = -y*rgb
+ y_bot = rgb
+ z_bot = -x*rgb
+
+ case(CHUNK_BC)
+
+ x_top = -rgt
+ y_top = y*rgt
+ z_top = x*rgt
+
+ x_bot = -rgb
+ y_bot = y*rgb
+ z_bot = x*rgb
+
+ case(CHUNK_BC_ANTIPODE)
+
+ x_top = rgt
+ y_top = -y*rgt
+ z_top = x*rgt
+
+ x_bot = rgb
+ y_bot = -y*rgb
+ z_bot = x*rgb
+
+ case default
+ stop 'incorrect chunk number in compute_coord_main_mesh'
+
+ end select
+
+ ! rotate the chunk to the right location if we do not mesh the full Earth
+ if(NCHUNKS /= 6) then
+
+ ! rotate bottom
+ vector_ori(1) = x_bot
+ vector_ori(2) = y_bot
+ vector_ori(3) = z_bot
+ do i = 1,NDIM
+ vector_rotated(i) = ZERO
+ do j = 1,NDIM
+ vector_rotated(i) = vector_rotated(i) + rotation_matrix(i,j)*vector_ori(j)
+ enddo
+ enddo
+ x_bot = vector_rotated(1)
+ y_bot = vector_rotated(2)
+ z_bot = vector_rotated(3)
+
+ ! rotate top
+ vector_ori(1) = x_top
+ vector_ori(2) = y_top
+ vector_ori(3) = z_top
+ do i = 1,NDIM
+ vector_rotated(i) = ZERO
+ do j = 1,NDIM
+ vector_rotated(i) = vector_rotated(i) + rotation_matrix(i,j)*vector_ori(j)
+ enddo
+ enddo
+ x_top = vector_rotated(1)
+ y_top = vector_rotated(2)
+ z_top = vector_rotated(3)
+
+ endif
+
+ ! compute the position of the point
+ rn = offset_z(ignod) / dble(ner)
+ xelm(ignod) = x_top*rn + x_bot*(ONE-rn)
+ yelm(ignod) = y_top*rn + y_bot*(ONE-rn)
+ zelm(ignod) = z_top*rn + z_bot*(ONE-rn)
+
+ endif
+ enddo
+! if(ilayer == NUMBER_OF_MESH_LAYERS .and. INCLUDE_CENTRAL_CUBE) write(IMAIN,*)
+ end subroutine compute_coord_main_mesh
+
+!---------------------------------------------------------------------------
+
+!! DK DK create value of arrays xgrid ygrid and zgrid in the central cube without storing them
+
+ subroutine compute_coord_central_cube(ix,iy,iz, &
+ 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)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: ix,iy,iz,iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,nx_central_cube,ny_central_cube,nz_central_cube
+
+ double precision :: xgrid_central_cube,ygrid_central_cube,zgrid_central_cube,radius_cube
+
+! local variables
+ double precision :: ratio_x,ratio_y,ratio_z
+ double precision :: fact_x,fact_y,fact_z,xi,eta,gamma
+ double precision, parameter :: PI_OVER_TWO = PI / 2.d0
+
+! the slice extends to the entire cube along Z
+! but only to current block along X and Y
+ ratio_x = (dble(iproc_xi) + dble(ix)/dble(2*nx_central_cube)) / dble(NPROC_XI)
+ ratio_y = (dble(iproc_eta) + dble(iy)/dble(2*ny_central_cube)) / dble(NPROC_ETA)
+ ratio_z = dble(iz)/dble(2*nz_central_cube)
+
+ if(abs(ratio_x) > 1.001d0 .or. abs(ratio_y) > 1.001d0 .or. abs(ratio_z) > 1.001d0) stop 'wrong ratio in central cube'
+
+! use a "flat" cubed sphere to create the central cube
+
+! map ratio to [-1,1] and then map to real radius
+! then add deformation
+ fact_x = 2.d0*ratio_x-1.d0
+ fact_y = 2.d0*ratio_y-1.d0
+ fact_z = 2.d0*ratio_z-1.d0
+
+ xi = PI_OVER_TWO*fact_x;
+ eta = PI_OVER_TWO*fact_y;
+ gamma = PI_OVER_TWO*fact_z;
+
+ xgrid_central_cube = radius_cube * fact_x * (1 + (cos(eta)+cos(gamma))*CENTRAL_CUBE_INFLATE_FACTOR / PI);
+ ygrid_central_cube = radius_cube * fact_y * (1 + (cos(xi)+cos(gamma))*CENTRAL_CUBE_INFLATE_FACTOR / PI);
+ zgrid_central_cube = radius_cube * fact_z * (1 + (cos(xi)+cos(eta))*CENTRAL_CUBE_INFLATE_FACTOR / PI);
+
+ end subroutine compute_coord_central_cube
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_element_properties.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_element_properties.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_element_properties.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_element_properties.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,473 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! compute several rheological and geometrical properties for a given spectral element
+ subroutine 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)
+
+ implicit none
+
+ include "constants.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(:), pointer :: 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 ispec,nspec,nspec_stacey
+
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ logical ELLIPTICITY,TOPOGRAPHY
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST
+
+ logical ATTENUATION,ATTENUATION_3D,ABSORBING_CONDITIONS
+
+ double precision RICB,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! 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)
+
+! code for the four regions of the mesh
+ integer iregion_code
+
+! 3D shape functions and their derivatives
+ double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
+ double precision, dimension(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ) :: dershape3D
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm
+
+! parameters needed to store the radii of the grid points
+! in the spherically symmetric Earth
+ integer idoubling(nspec)
+ double precision rmin,rmax
+
+! for model density and anisotropy
+ integer nspec_ani
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
+!! DK DK added this for the merged version
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: kappavstore_local
+!! DK DK changed this for merged version
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: rhostore_local
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store
+
+!! DK DK added this for merged version
+ integer :: value_idoubling_to_send
+
+!! 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
+
+! proc numbers for MPI
+ integer myrank
+
+! Stacey, indices for Clayton-Engquist absorbing conditions
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
+
+! attenuation
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: Qmu_store
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec) :: tau_e_store
+ double precision, dimension(N_SLS) :: tau_s
+ double precision T_c_source
+
+ 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)
+
+! **************
+! add topography on the Moho *before* adding the 3D crustal model so that the streched
+! mesh gets assigned the right model values
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ if(THREE_D_MODEL/=0 .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
+ .or. idoubling(ispec)==IFLAG_80_MOHO)) call moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220)
+ endif
+
+! compute values for the Earth model
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ value_idoubling_to_send = idoubling(ispec)
+ else
+ value_idoubling_to_send = IFLAG_OUTER_CORE_NORMAL
+ endif
+ call get_model(myrank,iregion_code,nspec, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,rhostore_local, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ nspec_ani, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ xelm,yelm,zelm,shape3D,ispec, &
+ rmin,rmax,value_idoubling_to_send,rho_vp,rho_vs,nspec_stacey, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ ATTENUATION, ATTENUATION_3D, tau_s, tau_e_store, Qmu_store, T_c_source, &
+ size(tau_e_store,2), size(tau_e_store,3), size(tau_e_store,4), size(tau_e_store,5), &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,&
+ 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)
+
+! add topography without the crustal model
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ if(TOPOGRAPHY .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
+ .or. idoubling(ispec)==IFLAG_80_MOHO)) call add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
+ endif
+
+! add topography on 410 km and 650 km discontinuity in model S362ANI
+ if(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) &
+ call add_topography_410_650(myrank,xelm,yelm,zelm,R220,R400,R670,R771, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,ylmcof,wk1,wk2,wk3,varstr)
+
+! CMB topography
+!! DK DK merged version: this will not work anymore because idoubling not allocated in outer core
+! if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .and. (idoubling(ispec)==IFLAG_MANTLE_NORMAL &
+! .or. idoubling(ispec)==IFLAG_OUTER_CORE_NORMAL)) &
+! call add_topography_cmb(myrank,xelm,yelm,zelm,RTOPDDOUBLEPRIME,RCMB)
+
+! ICB topography
+!! DK DK merged version: this will not work anymore because idoubling not allocated in outer core
+! if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .and. (idoubling(ispec)==IFLAG_OUTER_CORE_NORMAL &
+! .or. idoubling(ispec)==IFLAG_INNER_CORE_NORMAL .or. 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)) &
+! call add_topography_icb(myrank,xelm,yelm,zelm,RICB,RCMB)
+
+! make the Earth elliptical
+ if(ELLIPTICITY) call get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2)
+
+! recompute coordinates and jacobian for real 3-D model
+ call calc_jacobian(myrank,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore,xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
+
+ end subroutine compute_element_properties
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_crust_mantle.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_crust_mantle.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_crust_mantle.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_crust_mantle.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,632 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 compute_forces_crust_mantle(displ,accel,xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ ibool,idoubling,R_memory,epsilondev,one_minus_sum_beta, &
+ alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec,COMPUTE_AND_STORE_STRAIN, AM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: 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
+
+! for forward or backward simulations
+ logical COMPUTE_AND_STORE_STRAIN
+
+! array with the local to global mapping per slice
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ,accel
+
+! memory variables for attenuation
+! memory variables R_ij are stored at the local rather than global level
+! to allow for optimization of cache access by compiler
+ integer i_sls,i_memory
+! variable sized array variables for one_minus_sum_beta and factor_common
+ integer vx, vy, vz, vnspec
+
+ real(kind=CUSTOM_REAL) one_minus_sum_beta_use,minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
+
+ integer iregion_selected
+
+! for attenuation
+ real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev
+
+! [alpha,beta,gamma]val reduced to N_SLS and factor_common to N_SLS*NUM_NODES
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
+ real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: factor_common
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+! 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
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+! x y and z contain r theta and phi
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: xstore,ystore,zstore
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
+ kappavstore,muvstore
+
+! store anisotropic properties only where needed to save memory
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ kappahstore,muhstore,eta_anisostore
+
+ integer ispec,iglob
+ integer i,j,k,l
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ real(kind=CUSTOM_REAL) c11,c22,c33,c44,c55,c66,c12,c13,c23,c14,c24,c34,c15,c25,c35,c45,c16,c26,c36,c46,c56
+
+ real(kind=CUSTOM_REAL) rhovphsq,sinphifour,cosphisq,sinphisq,costhetasq,rhovsvsq,sinthetasq, &
+ cosphifour,costhetafour,rhovpvsq,sinthetafour,rhovshsq,cosfourphi, &
+ costwotheta,cosfourtheta,sintwophisq,costheta,sinphi,sintheta,cosphi, &
+ sintwotheta,costwophi,sintwophi,costwothetasq,costwophisq,phi,theta
+
+ real(kind=CUSTOM_REAL) two_rhovpvsq,two_rhovphsq,two_rhovsvsq,two_rhovshsq
+ real(kind=CUSTOM_REAL) four_rhovpvsq,four_rhovphsq,four_rhovsvsq,four_rhovshsq
+
+ real(kind=CUSTOM_REAL) twoetaminone,etaminone,eta_aniso
+ real(kind=CUSTOM_REAL) two_eta_aniso,four_eta_aniso,six_eta_aniso
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+
+ real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+
+ real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+
+ real(kind=CUSTOM_REAL) hp1,hp2,hp3
+ real(kind=CUSTOM_REAL) fac1,fac2,fac3
+ real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) kappal,kappavl,kappahl,muvl,muhl
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
+
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+
+! for gravity
+ real(kind=CUSTOM_REAL) radius_cr
+
+! ****************************************************
+! big loop over all spectral elements in the solid
+! ****************************************************
+
+! set acceleration to zero
+ accel(:,:) = 0._CUSTOM_REAL
+
+ do ispec = 1,NSPEC_CRUST_MANTLE
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + displ(1,iglob)*hp1
+ tempy1l = tempy1l + displ(2,iglob)*hp1
+ tempz1l = tempz1l + displ(3,iglob)*hp1
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(j,l)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + displ(1,iglob)*hp2
+ tempy2l = tempy2l + displ(2,iglob)*hp2
+ tempz2l = tempz2l + displ(3,iglob)*hp2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(k,l)
+ iglob = ibool(i,j,l,ispec)
+ tempx3l = tempx3l + displ(1,iglob)*hp3
+ tempy3l = tempy3l + displ(2,iglob)*hp3
+ tempz3l = tempz3l + displ(3,iglob)*hp3
+ enddo
+
+! get derivatives of ux, uy and uz with respect to x, y and z
+
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+
+ duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+
+! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
+
+! compute deviatoric strain
+ if (COMPUTE_AND_STORE_STRAIN) then
+ epsilondev_loc(1,i,j,k) = duxdxl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(2,i,j,k) = duydyl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
+ endif
+
+! precompute terms for attenuation if needed
+ if(ATTENUATION_VAL) then
+ radius_cr = xstore(ibool(i,j,k,ispec))
+ call get_attenuation_index(idoubling(ispec), dble(radius_cr), iregion_selected, .FALSE., AM_V)
+ one_minus_sum_beta_use = one_minus_sum_beta(1,1,1,iregion_selected)
+ minus_sum_beta = one_minus_sum_beta_use - 1.0
+ endif
+
+!
+! compute either isotropic or anisotropic elements
+!
+
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+
+ else
+
+! do not use transverse isotropy except if element is between d220 and Moho
+ if(.not. (TRANSVERSE_ISOTROPY_VAL .and. (idoubling(ispec)==IFLAG_220_80 .or. idoubling(ispec)==IFLAG_80_MOHO))) then
+
+! layer with no transverse isotropy, use kappav and muv
+ kappal = kappavstore(i,j,k,ispec)
+ mul = muvstore(i,j,k,ispec)
+
+! use unrelaxed parameters if attenuation
+ if(ATTENUATION_VAL) mul = mul * one_minus_sum_beta_use
+
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
+
+! compute stress sigma
+
+ sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
+
+ else
+
+! use Kappa and mu from transversely isotropic model
+ kappavl = kappavstore(i,j,k,ispec)
+ muvl = muvstore(i,j,k,ispec)
+
+ kappahl = kappahstore(i,j,k,ispec)
+ muhl = muhstore(i,j,k,ispec)
+
+! use unrelaxed parameters if attenuation
+! eta does not need to be shifted since it is a ratio
+ if(ATTENUATION_VAL) then
+ muvl = muvl * one_minus_sum_beta_use
+ muhl = muhl * one_minus_sum_beta_use
+ endif
+
+ rhovpvsq = kappavl + FOUR_THIRDS * muvl !!! that is C
+ rhovphsq = kappahl + FOUR_THIRDS * muhl !!! that is A
+
+ rhovsvsq = muvl !!! that is L
+ rhovshsq = muhl !!! that is N
+
+ eta_aniso = eta_anisostore(i,j,k,ispec) !!! that is F / (A - 2 L)
+
+! use mesh coordinates to get theta and phi
+! ystore and zstore contain theta and phi
+
+ iglob = ibool(i,j,k,ispec)
+ theta = ystore(iglob)
+ phi = zstore(iglob)
+
+ costheta = cos(theta)
+ sintheta = sin(theta)
+ cosphi = cos(phi)
+ sinphi = sin(phi)
+
+ costhetasq = costheta * costheta
+ sinthetasq = sintheta * sintheta
+ cosphisq = cosphi * cosphi
+ sinphisq = sinphi * sinphi
+
+ costhetafour = costhetasq * costhetasq
+ sinthetafour = sinthetasq * sinthetasq
+ cosphifour = cosphisq * cosphisq
+ sinphifour = sinphisq * sinphisq
+
+ costwotheta = cos(2.*theta)
+ sintwotheta = sin(2.*theta)
+ costwophi = cos(2.*phi)
+ sintwophi = sin(2.*phi)
+
+ cosfourtheta = cos(4.*theta)
+ cosfourphi = cos(4.*phi)
+
+ costwothetasq = costwotheta * costwotheta
+
+ costwophisq = costwophi * costwophi
+ sintwophisq = sintwophi * sintwophi
+
+ etaminone = eta_aniso - 1.
+ twoetaminone = 2. * eta_aniso - 1.
+
+! precompute some products to reduce the CPU time
+
+ two_eta_aniso = 2.*eta_aniso
+ four_eta_aniso = 4.*eta_aniso
+ six_eta_aniso = 6.*eta_aniso
+
+ two_rhovpvsq = 2.*rhovpvsq
+ two_rhovphsq = 2.*rhovphsq
+ two_rhovsvsq = 2.*rhovsvsq
+ two_rhovshsq = 2.*rhovshsq
+
+ four_rhovpvsq = 4.*rhovpvsq
+ four_rhovphsq = 4.*rhovphsq
+ four_rhovsvsq = 4.*rhovsvsq
+ four_rhovshsq = 4.*rhovshsq
+
+! the 21 anisotropic coefficients computed using Mathematica
+
+ c11 = rhovphsq*sinphifour + 2.*cosphisq*sinphisq* &
+ (rhovphsq*costhetasq + (eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
+ sinthetasq) + cosphifour* &
+ (rhovphsq*costhetafour + 2.*(eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
+ costhetasq*sinthetasq + rhovpvsq*sinthetafour)
+
+ c12 = ((rhovphsq - two_rhovshsq)*(3. + cosfourphi)*costhetasq)/4. - &
+ four_rhovshsq*cosphisq*costhetasq*sinphisq + &
+ (rhovphsq*(11. + 4.*costwotheta + cosfourtheta)*sintwophisq)/32. + &
+ eta_aniso*(rhovphsq - two_rhovsvsq)*(cosphifour + &
+ 2.*cosphisq*costhetasq*sinphisq + sinphifour)*sinthetasq + &
+ rhovpvsq*cosphisq*sinphisq*sinthetafour - &
+ rhovsvsq*sintwophisq*sinthetafour
+
+ c13 = (cosphisq*(rhovphsq + six_eta_aniso*rhovphsq + rhovpvsq - four_rhovsvsq - &
+ 12.*eta_aniso*rhovsvsq + (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - &
+ four_eta_aniso*rhovsvsq)*cosfourtheta))/8. + &
+ sinphisq*(eta_aniso*(rhovphsq - two_rhovsvsq)*costhetasq + &
+ (rhovphsq - two_rhovshsq)*sinthetasq)
+
+ c14 = costheta*sinphi*((cosphisq* &
+ (-rhovphsq + rhovpvsq + four_rhovshsq - four_rhovsvsq + &
+ (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
+ four_eta_aniso*rhovsvsq)*costwotheta))/2. + &
+ (etaminone*rhovphsq + 2.*(rhovshsq - eta_aniso*rhovsvsq))*sinphisq)* sintheta
+
+ c15 = cosphi*costheta*((cosphisq* (-rhovphsq + rhovpvsq + &
+ (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
+ costwotheta))/2. + etaminone*(rhovphsq - two_rhovsvsq)*sinphisq)*sintheta
+
+ c16 = (cosphi*sinphi*(cosphisq* (-rhovphsq + rhovpvsq + &
+ (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
+ four_eta_aniso*rhovsvsq)*costwotheta) + &
+ 2.*etaminone*(rhovphsq - two_rhovsvsq)*sinphisq)*sinthetasq)/2.
+
+ c22 = rhovphsq*cosphifour + 2.*cosphisq*sinphisq* &
+ (rhovphsq*costhetasq + (eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
+ sinthetasq) + sinphifour* &
+ (rhovphsq*costhetafour + 2.*(eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
+ costhetasq*sinthetasq + rhovpvsq*sinthetafour)
+
+ c23 = ((rhovphsq + six_eta_aniso*rhovphsq + rhovpvsq - four_rhovsvsq - 12.*eta_aniso*rhovsvsq + &
+ (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
+ cosfourtheta)*sinphisq)/8. + &
+ cosphisq*(eta_aniso*(rhovphsq - two_rhovsvsq)*costhetasq + &
+ (rhovphsq - two_rhovshsq)*sinthetasq)
+
+ c24 = costheta*sinphi*(etaminone*(rhovphsq - two_rhovsvsq)*cosphisq + &
+ ((-rhovphsq + rhovpvsq + (twoetaminone*rhovphsq - rhovpvsq + &
+ four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)*sintheta
+
+ c25 = cosphi*costheta*((etaminone*rhovphsq + 2.*(rhovshsq - eta_aniso*rhovsvsq))* &
+ cosphisq + ((-rhovphsq + rhovpvsq + four_rhovshsq - four_rhovsvsq + &
+ (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
+ four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)*sintheta
+
+ c26 = (cosphi*sinphi*(2.*etaminone*(rhovphsq - two_rhovsvsq)*cosphisq + &
+ (-rhovphsq + rhovpvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
+ four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)*sinthetasq)/2.
+
+ c33 = rhovpvsq*costhetafour + 2.*(eta_aniso*(rhovphsq - two_rhovsvsq) + two_rhovsvsq)* &
+ costhetasq*sinthetasq + rhovphsq*sinthetafour
+
+ c34 = -((rhovphsq - rhovpvsq + (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq &
+ - four_eta_aniso*rhovsvsq)*costwotheta)*sinphi*sintwotheta)/4.
+
+ c35 = -(cosphi*(rhovphsq - rhovpvsq + &
+ (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
+ costwotheta)*sintwotheta)/4.
+
+ c36 = -((rhovphsq - rhovpvsq - four_rhovshsq + four_rhovsvsq + &
+ (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
+ costwotheta)*sintwophi*sinthetasq)/4.
+
+ c44 = cosphisq*(rhovsvsq*costhetasq + rhovshsq*sinthetasq) + &
+ sinphisq*(rhovsvsq*costwothetasq + &
+ (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + four_eta_aniso*rhovsvsq)*costhetasq* sinthetasq)
+
+ c45 = ((rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
+ four_eta_aniso*rhovsvsq + (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + &
+ 4.*etaminone*rhovsvsq)*costwotheta)*sintwophi*sinthetasq)/4.
+
+ c46 = -(cosphi*costheta*((rhovshsq - rhovsvsq)*cosphisq - &
+ ((rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
+ four_eta_aniso*rhovsvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + &
+ four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)* sintheta)
+
+ c55 = sinphisq*(rhovsvsq*costhetasq + rhovshsq*sinthetasq) + &
+ cosphisq*(rhovsvsq*costwothetasq + &
+ (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + four_eta_aniso*rhovsvsq)*costhetasq* sinthetasq)
+
+ c56 = costheta*sinphi*((cosphisq* &
+ (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
+ four_eta_aniso*rhovsvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + &
+ four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta))/2. + &
+ (-rhovshsq + rhovsvsq)*sinphisq)*sintheta
+
+ c66 = rhovshsq*costwophisq*costhetasq - &
+ 2.*(rhovphsq - two_rhovshsq)*cosphisq*costhetasq*sinphisq + &
+ (rhovphsq*(11. + 4.*costwotheta + cosfourtheta)*sintwophisq)/32. - &
+ (rhovsvsq*(-6. - 2.*cosfourphi + cos(4.*phi - 2.*theta) - 2.*costwotheta + &
+ cos(2.*(2.*phi + theta)))*sinthetasq)/8. + &
+ rhovpvsq*cosphisq*sinphisq*sinthetafour - &
+ (eta_aniso*(rhovphsq - two_rhovsvsq)*sintwophisq*sinthetafour)/2.
+
+! general expression of stress tensor for full Cijkl with 21 coefficients
+
+ sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
+ c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
+
+ sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
+ c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
+
+ sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
+ c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
+
+ sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
+ c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
+
+ sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
+ c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
+
+ sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
+ c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
+
+ endif
+
+ endif ! end of test whether isotropic or anisotropic element
+
+! subtract memory variables if attenuation
+ if(ATTENUATION_VAL) then
+ do i_sls = 1,N_SLS
+ R_xx_val = R_memory(1,i_sls,i,j,k,ispec)
+ R_yy_val = R_memory(2,i_sls,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val
+ sigma_yy = sigma_yy - R_yy_val
+ sigma_zz = sigma_zz + R_xx_val + R_yy_val
+ sigma_xy = sigma_xy - R_memory(3,i_sls,i,j,k,ispec)
+ sigma_xz = sigma_xz - R_memory(4,i_sls,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
+ enddo
+ endif
+
+! form dot product with test vector, symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempy1l = 0._CUSTOM_REAL
+ tempz1l = 0._CUSTOM_REAL
+
+ tempx2l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+
+ tempx3l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ fac1 = hprimewgll_xx(l,i)
+ tempx1l = tempx1l + tempx1(l,j,k)*fac1
+ tempy1l = tempy1l + tempy1(l,j,k)*fac1
+ tempz1l = tempz1l + tempz1(l,j,k)*fac1
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ fac2 = hprimewgll_yy(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ fac3 = hprimewgll_zz(l,k)
+ tempx3l = tempx3l + tempx3(i,j,l)*fac3
+ tempy3l = tempy3l + tempy3(i,j,l)*fac3
+ tempz3l = tempz3l + tempz3(i,j,l)*fac3
+ enddo
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+
+ sum_terms(1,i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ sum_terms(2,i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ sum_terms(3,i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ enddo
+ enddo
+ enddo
+
+! sum contributions from each element to the global mesh and add gravity terms
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) + sum_terms(1,i,j,k)
+ accel(2,iglob) = accel(2,iglob) + sum_terms(2,i,j,k)
+ accel(3,iglob) = accel(3,iglob) + sum_terms(3,i,j,k)
+ enddo
+ enddo
+ enddo
+
+! update memory variables based upon the Runge-Kutta scheme
+! convention for attenuation
+! term in xx = 1
+! term in yy = 2
+! term in xy = 3
+! term in xz = 4
+! term in yz = 5
+! term in zz not computed since zero trace
+
+ if(ATTENUATION_VAL) then
+
+! use Runge-Kutta scheme to march in time
+ do i_sls = 1,N_SLS
+ do i_memory = 1,5
+
+! get coefficients for that standard linear solid
+! IMPROVE we use mu_v here even if there is some anisotropy
+! IMPROVE we should probably use an average value instead
+
+ R_memory(i_memory,i_sls,:,:,:,ispec) = alphaval(i_sls) * &
+ R_memory(i_memory,i_sls,:,:,:,ispec) + &
+ factor_common(i_sls,1,1,1,iregion_selected) * muvstore(:,:,:,ispec) * &
+ (betaval(i_sls) * epsilondev(i_memory,:,:,:,ispec) + &
+ gammaval(i_sls) * epsilondev_loc(i_memory,:,:,:))
+ enddo
+ enddo
+
+ endif
+
+! save deviatoric strain for Runge-Kutta scheme
+ if(COMPUTE_AND_STORE_STRAIN) epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
+
+ enddo ! spectral element loop
+
+ end subroutine compute_forces_crust_mantle
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_inner_core.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_inner_core.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_inner_core.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_inner_core.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,399 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 compute_forces_inner_core(displ,accel,xstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappavstore,muvstore,ibool,idoubling, &
+ R_memory,epsilondev,&
+ one_minus_sum_beta,alphaval,betaval,gammaval,factor_common, &
+ vx,vy,vz,vnspec,COMPUTE_AND_STORE_STRAIN, AM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: 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
+
+! for forward or backward simulations
+ logical COMPUTE_AND_STORE_STRAIN
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ,accel
+
+! for attenuation
+! memory variables R_ij are stored at the local rather than global level
+! to allow for optimization of cache access by compiler
+ integer i_sls,i_memory
+ real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
+
+! variable lengths for factor_common and one_minus_sum_beta
+ integer vx, vy, vz, vnspec
+
+ real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: factor_common
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+
+! array with the local to global mapping per slice
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: xix,xiy,xiz, &
+ etax,etay,etaz,gammax,gammay,gammaz
+
+! 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
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: kappavstore,muvstore
+
+ integer ispec,iglob
+ integer i,j,k,l
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+
+ real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+
+ real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+
+ real(kind=CUSTOM_REAL) hp1,hp2,hp3
+ real(kind=CUSTOM_REAL) fac1,fac2,fac3
+ real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) kappal
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
+
+ real(kind=CUSTOM_REAL) minus_sum_beta
+
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+
+! for gravity
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: xstore
+ integer iregion_selected
+
+ real(kind=CUSTOM_REAL) radius_cr
+
+! ****************************************************
+! big loop over all spectral elements in the solid
+! ****************************************************
+
+! set acceleration to zero
+ accel(:,:) = 0._CUSTOM_REAL
+
+ do ispec = 1,NSPEC_INNER_CORE
+
+! exclude fictitious elements in central cube
+ if(idoubling(ispec) /= IFLAG_IN_FICTITIOUS_CUBE) then
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + displ(1,iglob)*hp1
+ tempy1l = tempy1l + displ(2,iglob)*hp1
+ tempz1l = tempz1l + displ(3,iglob)*hp1
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(j,l)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + displ(1,iglob)*hp2
+ tempy2l = tempy2l + displ(2,iglob)*hp2
+ tempz2l = tempz2l + displ(3,iglob)*hp2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(k,l)
+ iglob = ibool(i,j,l,ispec)
+ tempx3l = tempx3l + displ(1,iglob)*hp3
+ tempy3l = tempy3l + displ(2,iglob)*hp3
+ tempz3l = tempz3l + displ(3,iglob)*hp3
+ enddo
+
+! get derivatives of ux, uy and uz with respect to x, y and z
+
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+
+ duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+
+! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
+
+! compute deviatoric strain
+ if (COMPUTE_AND_STORE_STRAIN) then
+ epsilondev_loc(1,i,j,k) = duxdxl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(2,i,j,k) = duydyl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
+ endif
+
+ if(ATTENUATION_VAL) then
+ radius_cr = xstore(ibool(i,j,k,ispec))
+ call get_attenuation_index(idoubling(ispec), dble(radius_cr), iregion_selected, .TRUE., AM_V)
+ minus_sum_beta = one_minus_sum_beta(1,1,1,iregion_selected) - 1.0
+ endif ! ATTENUATION_VAL
+
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+
+ else
+
+! inner core with no anisotropy, use kappav and muv for instance
+! layer with no anisotropy, use kappav and muv for instance
+ kappal = kappavstore(i,j,k,ispec)
+ mul = muvstore(i,j,k,ispec)
+
+! use unrelaxed parameters if attenuation
+ if(ATTENUATION_VAL) then
+ mul = mul * one_minus_sum_beta(1,1,1,iregion_selected)
+ endif
+
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
+
+! compute stress sigma
+
+ sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
+
+ endif
+
+! subtract memory variables if attenuation
+ if(ATTENUATION_VAL) then
+ do i_sls = 1,N_SLS
+ R_xx_val = R_memory(1,i_sls,i,j,k,ispec)
+ R_yy_val = R_memory(2,i_sls,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val
+ sigma_yy = sigma_yy - R_yy_val
+ sigma_zz = sigma_zz + R_xx_val + R_yy_val
+ sigma_xy = sigma_xy - R_memory(3,i_sls,i,j,k,ispec)
+ sigma_xz = sigma_xz - R_memory(4,i_sls,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
+ enddo
+ endif
+
+! form dot product with test vector, symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempy1l = 0._CUSTOM_REAL
+ tempz1l = 0._CUSTOM_REAL
+
+ tempx2l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+
+ tempx3l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ fac1 = hprimewgll_xx(l,i)
+ tempx1l = tempx1l + tempx1(l,j,k)*fac1
+ tempy1l = tempy1l + tempy1(l,j,k)*fac1
+ tempz1l = tempz1l + tempz1(l,j,k)*fac1
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ fac2 = hprimewgll_yy(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ fac3 = hprimewgll_zz(l,k)
+ tempx3l = tempx3l + tempx3(i,j,l)*fac3
+ tempy3l = tempy3l + tempy3(i,j,l)*fac3
+ tempz3l = tempz3l + tempz3(i,j,l)*fac3
+ enddo
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+
+ sum_terms(1,i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ sum_terms(2,i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ sum_terms(3,i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ enddo
+ enddo
+ enddo
+
+! sum contributions from each element to the global mesh and add gravity terms
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ accel(:,iglob) = accel(:,iglob) + sum_terms(:,i,j,k)
+ enddo
+ enddo
+ enddo
+
+! use Runge-Kutta scheme to march memory variables in time
+! convention for attenuation
+! term in xx = 1
+! term in yy = 2
+! term in xy = 3
+! term in xz = 4
+! term in yz = 5
+! term in zz not computed since zero trace
+
+ if(ATTENUATION_VAL) then
+
+ do i_sls = 1,N_SLS
+ do i_memory = 1,5
+ R_memory(i_memory,i_sls,:,:,:,ispec) = &
+ alphaval(i_sls) * &
+ R_memory(i_memory,i_sls,:,:,:,ispec) + muvstore(:,:,:,ispec) * &
+ factor_common(i_sls,1,1,1,iregion_selected) * &
+ (betaval(i_sls) * &
+ epsilondev(i_memory,:,:,:,ispec) + gammaval(i_sls) * epsilondev_loc(i_memory,:,:,:))
+ enddo
+ enddo
+
+ endif
+
+ if (COMPUTE_AND_STORE_STRAIN) then
+! save deviatoric strain for Runge-Kutta scheme
+ epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
+ endif
+
+ endif ! end test to exclude fictitious elements in central cube
+
+ enddo ! spectral element loop
+
+ end subroutine compute_forces_inner_core
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_outer_core.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_outer_core.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_outer_core.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_forces_outer_core.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,224 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 compute_forces_outer_core(d_ln_density_dr_table, &
+ displfluid,accelfluid,xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,ibool)
+
+ implicit none
+
+ include "constants.h"
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: displfluid,accelfluid
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec_outer_core) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_outer_core) :: xix,xiy,xiz, &
+ etax,etay,etaz,gammax,gammay,gammaz
+
+! 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
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: tempx1,tempx2,tempx3
+
+! for gravity
+ integer int_radius
+ double precision radius,theta,phi
+ double precision cos_theta,sin_theta,cos_phi,sin_phi
+ double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
+ real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: xstore,ystore,zstore
+
+ integer ispec,iglob
+ integer i,j,k,l
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+
+ double precision grad_x_ln_rho,grad_y_ln_rho,grad_z_ln_rho
+! ****************************************************
+! big loop over all spectral elements in the fluid
+! ****************************************************
+
+! set acceleration to zero
+ accelfluid(:) = 0._CUSTOM_REAL
+
+ do ispec = 1,NSPEC_OUTER_CORE
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ iglob = ibool(i,j,k,ispec)
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ tempx1l = tempx1l + displfluid(ibool(l,j,k,ispec)) * hprime_xx(i,l)
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ tempx2l = tempx2l + displfluid(ibool(i,l,k,ispec)) * hprime_yy(j,l)
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ tempx3l = tempx3l + displfluid(ibool(i,j,l,ispec)) * hprime_zz(k,l)
+ enddo
+
+! get derivatives of velocity potential with respect to x, y and z
+
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ dpotentialdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ dpotentialdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ dpotentialdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+! add (chi/rho)grad(rho) term in no gravity case
+
+! With regards to the non-gravitating case: we cannot set N^2 = 0 *and* let g = 0.
+! We can *either* assume N^2 = 0 but keep gravity g, *or* we can assume that gravity
+! is negligible to begin with, as in our GJI 2002a, in which case N does not arise.
+! We get:
+!
+! \ddot\chi = \rho^{-1}\kappa\bdel\cdot(\bdel\chi+\chi\bdel\ln\rho)
+!
+! Then the displacement is
+!
+! \bu = \bdel\chi+\chi\bdel\ln\rho = \rho^{-1}\bdel(\rho\chi)
+!
+! and the pressure is
+!
+! p = -\rho\ddot{\chi}
+!
+! Thus in our 2002b GJI paper eqn (21) is wrong, and equation (41)
+! in our AGU monograph is incorrect; these equations should be replaced by
+!
+! \ddot\chi = \rho^{-1}\kappa\bdel\cdot(\bdel\chi+\chi\bdel\ln\rho)
+!
+! Note that the fluid potential we use in GJI 2002a differs from the one used here:
+!
+! \chi_GJI2002a = \rho\partial\t\chi
+!
+! such that
+!
+! \bv = \partial_t\bu=\rho^{-1}\bdel\chi_GJI2002a (GJI 2002a eqn 20)
+!
+! p = - \partial_t\chi_GJI2002a (GJI 2002a eqn 19)
+
+! use mesh coordinates to get theta and phi
+! x y z contain r theta phi
+
+ radius = dble(xstore(iglob))
+ theta = dble(ystore(iglob))
+ phi = dble(zstore(iglob))
+
+ cos_theta = dcos(theta)
+ sin_theta = dsin(theta)
+ cos_phi = dcos(phi)
+ sin_phi = dsin(phi)
+
+ int_radius = nint(radius * R_EARTH_KM * 10.d0)
+
+! grad(rho)/rho in Cartesian components
+ grad_x_ln_rho = sin_theta * cos_phi * d_ln_density_dr_table(int_radius)
+ grad_y_ln_rho = sin_theta * sin_phi * d_ln_density_dr_table(int_radius)
+ grad_z_ln_rho = cos_theta * d_ln_density_dr_table(int_radius)
+
+! adding (chi/rho)grad(rho)
+ dpotentialdxl = dpotentialdxl + displfluid(iglob) * grad_x_ln_rho
+ dpotentialdyl = dpotentialdyl + displfluid(iglob) * grad_y_ln_rho
+ dpotentialdzl = dpotentialdzl + displfluid(iglob) * grad_z_ln_rho
+
+ tempx1(i,j,k) = jacobianl*(xixl*dpotentialdxl + xiyl*dpotentialdyl + xizl*dpotentialdzl)
+ tempx2(i,j,k) = jacobianl*(etaxl*dpotentialdxl + etayl*dpotentialdyl + etazl*dpotentialdzl)
+ tempx3(i,j,k) = jacobianl*(gammaxl*dpotentialdxl + gammayl*dpotentialdyl + gammazl*dpotentialdzl)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ tempx1l = tempx1l + tempx1(l,j,k) * hprimewgll_xx(l,i)
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ tempx2l = tempx2l + tempx2(i,l,k) * hprimewgll_yy(l,j)
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ tempx3l = tempx3l + tempx3(i,j,l) * hprimewgll_zz(l,k)
+ enddo
+
+! sum contributions from each element to the global mesh and add gravity term
+
+ iglob = ibool(i,j,k,ispec)
+ accelfluid(iglob) = accelfluid(iglob) - (wgllwgll_yz(j,k)*tempx1l + wgllwgll_xz(i,k)*tempx2l + wgllwgll_xy(i,j)*tempx3l)
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! spectral element loop
+
+ end subroutine compute_forces_outer_core
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/convolve_source_timefunction.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/convolve_source_timefunction.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/convolve_source_timefunction.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/convolve_source_timefunction.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,135 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+ program convolve_source_time_function
+
+!
+! convolve seismograms computed for a Heaviside with given source time function
+!
+
+! we mimic a triangle of half duration equal to half_duration_triangle
+! using a Gaussian having a very close shape, as explained in Figure 4.2
+! of the manual
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: i,j,N_j,number_remove,nlines
+
+ double precision :: alpha,dt,tau_j,source,exponent,t1,t2,displ1,displ2,gamma,height,half_duration_triangle
+
+ logical :: triangle
+
+ double precision, dimension(:), allocatable :: time,sem,sem_fil
+
+! read file with number of lines in input
+ open(unit=33,file='input_convolve_code.txt',status='old',action='read')
+ read(33,*) nlines
+ read(33,*) half_duration_triangle
+ read(33,*) triangle
+ close(33)
+
+! allocate arrays
+ allocate(time(nlines),sem(nlines),sem_fil(nlines))
+
+! read the input seismogram
+ do i = 1,nlines
+ read(5,*) time(i),sem(i)
+ enddo
+
+! define a Gaussian with the right exponent to mimic a triangle of equivalent half duration
+ alpha = SOURCE_DECAY_MIMIC_TRIANGLE/half_duration_triangle
+
+! compute the time step
+ dt = time(2) - time(1)
+
+! number of integers for which the source wavelet is different from zero
+ if(triangle) then
+ N_j = ceiling(half_duration_triangle/dt)
+ else
+ N_j = ceiling(1.5d0*half_duration_triangle/dt)
+ endif
+
+ do i = 1,nlines
+
+ sem_fil(i) = 0.d0
+
+ do j = -N_j,N_j
+
+ if(i > j .and. i-j <= nlines) then
+
+ tau_j = dble(j)*dt
+
+! convolve with a triangle
+ if(triangle) then
+ height = 1.d0 / half_duration_triangle
+ if(abs(tau_j) > half_duration_triangle) then
+ source = 0.d0
+ else if (tau_j < 0.d0) then
+ t1 = - N_j * dt
+ displ1 = 0.d0
+ t2 = 0.d0
+ displ2 = height
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1.d0 - gamma) * displ1 + gamma * displ2
+ else
+ t1 = 0.d0
+ displ1 = height
+ t2 = + N_j * dt
+ displ2 = 0.d0
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1.d0 - gamma) * displ1 + gamma * displ2
+ endif
+
+ else
+
+! convolve with a Gaussian
+ exponent = alpha**2 * tau_j**2
+ if(exponent < 50.d0) then
+ source = alpha*exp(-exponent)/sqrt(PI)
+ else
+ source = 0.d0
+ endif
+
+ endif
+
+ sem_fil(i) = sem_fil(i) + sem(i-j)*source*dt
+
+ endif
+
+ enddo
+ enddo
+
+! compute number of samples to remove from end of seismograms
+ number_remove = N_j + 1
+ do i=1,nlines - number_remove
+ write(*,*) sngl(time(i)),' ',sngl(sem_fil(i))
+ enddo
+
+ end program convolve_source_time_function
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/count_number_of_sources.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/count_number_of_sources.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/count_number_of_sources.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/count_number_of_sources.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,62 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 count_number_of_sources(NSOURCES)
+
+! count the total number of sources in the CMTSOLUTION file
+! there are NLINES_PER_CMTSOLUTION_SOURCE lines per source in that file
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(out) :: NSOURCES
+
+ integer ios,icounter
+
+ character(len=150) CMTSOLUTION,dummystring
+
+ call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
+
+ open(unit=1,file=CMTSOLUTION,iostat=ios,status='old',action='read')
+ if(ios /= 0) stop 'error opening CMTSOLUTION file'
+ icounter = 0
+ do while(ios == 0)
+ read(1,"(a)",iostat=ios) dummystring
+ if(ios == 0) icounter = icounter + 1
+ enddo
+ close(1)
+
+ 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'
+
+ end subroutine count_number_of_sources
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_central_cube_buffers.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,541 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,1123 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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,LOCAL_PATH, &
+ 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,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 "OUTPUT_FILES/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) :: 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) OUTPUT_FILES,LOCAL_PATH,ERR_MSG
+
+! array with the local to global mapping per slice
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+! mask for ibool to mark points already found
+ logical, dimension(:), allocatable :: mask_ibool
+
+! array to store points selected for the chunk face buffer
+ integer, dimension(:), allocatable :: ibool_selected
+
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+
+! pairs generated theoretically
+! four sides for each of the three types of messages
+ integer, dimension(:), allocatable :: iproc_sender,iproc_receiver,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(:,:), allocatable :: 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,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
+
+! names of the data files for all the processors in MPI
+ character(len=150) prname
+
+! 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')
+
+! allocate arrays for faces
+ allocate(iproc_sender(NUMMSGS_FACES))
+ allocate(iproc_receiver(NUMMSGS_FACES))
+ allocate(npoin2D_send(NUMMSGS_FACES))
+ allocate(npoin2D_receive(NUMMSGS_FACES))
+
+! allocate array for corners
+ allocate(iprocscorners(3,NCORNERSCHUNKS))
+ allocate(itypecorner(3,NCORNERSCHUNKS))
+
+! clear arrays allocated
+ iproc_sender(:) = 0
+ iproc_receiver(:) = 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
+
+! allocate arrays for message buffers with maximum size
+ allocate(ibool_selected(NGLOB2DMAX_XY))
+ allocate(xstore_selected(NGLOB2DMAX_XY))
+ allocate(ystore_selected(NGLOB2DMAX_XY))
+ allocate(zstore_selected(NGLOB2DMAX_XY))
+ allocate(ind(NGLOB2DMAX_XY))
+ allocate(ninseg(NGLOB2DMAX_XY))
+ allocate(iglob(NGLOB2DMAX_XY))
+ allocate(locval(NGLOB2DMAX_XY))
+ allocate(ifseg(NGLOB2DMAX_XY))
+ allocate(iwork(NGLOB2DMAX_XY))
+ allocate(work(NGLOB2DMAX_XY))
+
+
+! allocate mask for ibool
+ allocate(mask_ibool(nglob_ori))
+
+ imsg = 0
+
+ if(myrank == 0) then
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! file to store the list of processors for each message for faces
+!!! DK DK for merged open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='unknown')
+
+ endif
+
+!!!!!!!!!! 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 = 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 == 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 == 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 == 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
+ iproc_sender(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
+ iproc_receiver(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
+
+! check that sender/receiver pair is ordered
+ if(iproc_sender(imsg) > iproc_receiver(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,iproc_sender(imsg),iproc_receiver(imsg)
+
+! loop on sender/receiver (1=sender 2=receiver)
+ do imode_comm=1,2
+
+ if(imode_comm == 1) then
+ iproc = iproc_sender(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 = iproc_receiver(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
+
+!---------------------------------------------------------------------
+
+! create the name of the database for each slice
+ call create_name_database(prname,iproc,iregion_code,LOCAL_PATH)
+
+! open file for 2D buffer
+!! DK DK suppressed in the merged version
+! open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
+
+! 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)
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! read boundary parameters
+!! DK DK suppressed in the merged version
+! open(unit=IIN,file=prname(1:len_trim(prname))//'boundary.bin',status='old',action='read',form='unformatted')
+!! DK DK suppressed in the merged version read(IIN) nspec2D_xmin
+!! DK DK suppressed in the merged version read(IIN) nspec2D_xmax
+!! DK DK suppressed in the merged version read(IIN) nspec2D_ymin
+!! DK DK suppressed in the merged version read(IIN) nspec2D_ymax
+!! DK DK suppressed in the merged version read(IIN) njunk
+!! DK DK suppressed in the merged version read(IIN) njunk
+!! DK DK suppressed in the merged version
+!! DK DK suppressed in the merged version read(IIN) ibelm_xmin
+!! DK DK suppressed in the merged version read(IIN) ibelm_xmax
+!! DK DK suppressed in the merged version read(IIN) ibelm_ymin
+!! DK DK suppressed in the merged version read(IIN) ibelm_ymax
+!! DK DK suppressed in the merged version close(IIN)
+
+! read 1D buffers to remove corner points
+!! DK DK suppressed in the merged version
+! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='old',action='read')
+!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
+!! DK DK suppressed in the merged version read(IIN,*) ibool1D_leftxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
+!! DK DK suppressed in the merged version enddo
+!! DK DK suppressed in the merged version close(IIN)
+
+!! DK DK suppressed in the merged version
+! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='old',action='read')
+!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
+!! DK DK suppressed in the merged version read(IIN,*) ibool1D_rightxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
+!! DK DK suppressed in the merged version enddo
+!! DK DK suppressed in the merged version close(IIN)
+
+!! DK DK suppressed in the merged version
+! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='old',action='read')
+!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
+!! DK DK suppressed in the merged version read(IIN,*) ibool1D_leftxi_righteta(ipoin1D),xdummy,ydummy,zdummy
+!! DK DK suppressed in the merged version enddo
+!! DK DK suppressed in the merged version close(IIN)
+
+!! DK DK suppressed in the merged version
+! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='old',action='read')
+!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
+!! DK DK suppressed in the merged version read(IIN,*) ibool1D_rightxi_righteta(ipoin1D),xdummy,ydummy,zdummy
+!! DK DK suppressed in the merged version enddo
+!! DK DK suppressed in the merged version close(IIN)
+
+! 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
+!
+
+! synchronize all the processes to make sure all the buffers are ready
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! 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,iproc_sender(imsg),MPI_COMM_WORLD,ier)
+ if(myrank /= iproc_sender(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,iproc_receiver(imsg),MPI_COMM_WORLD,ier)
+ if(myrank /= iproc_receiver(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
+
+! file to store the list of processors for each message for corners
+!!! DK DK for merged if(myrank == 0) open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='unknown')
+
+! 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 /= iproc_master_corners(imsg)) call exit_MPI(myrank,'this message should be for a master')
+ if(imember_corner == 2 .and. myrank /= iproc_worker1_corners(imsg)) call exit_MPI(myrank,'this message should be for a worker1')
+ if(imember_corner == 3 .and. myrank /= iproc_worker2_corners(imsg)) call exit_MPI(myrank,'this message should be for a worker2')
+ icount_corners = 0
+ do imsg2 = 1,imsg
+ if(myrank == iproc_master_corners(imsg2) .or. &
+ myrank == iproc_worker1_corners(imsg2) .or. &
+ myrank == iproc_worker2_corners(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
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ else
+ call exit_MPI(myrank,'incorrect corner coordinates')
+ endif
+
+! read 1D buffer for corner
+!! DK DK suppressed in the merged version open(unit=IIN,file=filename_in,status='old',action='read')
+ do ipoin1D = 1,NGLOB1D_RADIAL_my_corner
+!! DK DK suppressed in the merged version read(IIN,*) ibool1D(ipoin1D), &
+!! DK DK suppressed in the merged version xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
+
+!! 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')
+
+! write file with 1D buffer for corner
+!! DK DK suppressed in the merged version open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
+!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) NGLOB1D_RADIAL_my_corner
+ do ipoin1D = 1,NGLOB1D_RADIAL_my_corner
+!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) ibool1D(ipoin1D), &
+!! DK DK suppressed in the merged version xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
+
+!! DK DK added this for merged version
+ iboolcorner(ipoin1D,icount_corners) = ibool1D(ipoin1D)
+
+ enddo
+!! DK DK suppressed in the merged version close(IOUT_BUFFERS)
+
+! end of section done only if right processor for MPI
+ endif
+
+ enddo
+
+ enddo
+
+!!! DK DK for merged if(myrank == 0) close(IOUT)
+
+! deallocate arrays
+ deallocate(iproc_sender)
+ deallocate(iproc_receiver)
+ deallocate(npoin2D_send)
+ deallocate(npoin2D_receive)
+
+ deallocate(iprocscorners)
+ deallocate(itypecorner)
+
+ deallocate(ibool_selected)
+ deallocate(xstore_selected)
+ deallocate(ystore_selected)
+ deallocate(zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+
+ deallocate(mask_ibool)
+
+ end subroutine create_chunk_buffers
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_header_file.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_header_file.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_header_file.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_header_file.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,238 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 file OUTPUT_FILES/values_from_mesher.h based upon DATA/Par_file
+! in order to compile the solver with the right array sizes
+
+ program xcreate_header_file
+
+ 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,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
+
+ 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,CASE_3D, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ nglob
+
+ double precision :: static_memory_size
+ character(len=150) HEADER_FILE
+
+ integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
+
+ integer :: iregion
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
+ integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
+
+! ************** PROGRAM STARTS HERE **************
+
+ call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
+ print *
+ print *,'creating file ', trim(HEADER_FILE), ' to compile solver with correct values'
+
+! 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,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
+
+! count the total number of sources in the CMTSOLUTION file
+ call count_number_of_sources(NSOURCES)
+
+ do iregion=1,MAX_NUM_REGIONS
+ NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
+ enddo
+
+ if (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA) then
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + &
+ maxval(DIFF_NSPEC1D_RADIAL(:,:))*(NGLLZ-1)
+ endif
+
+! evaluate the amount of static memory needed by the solver
+ call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+ ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+ ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+ NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+ NGLOB1D_RADIAL_TEMP(:) = &
+ (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
+
+! create include file for the solver
+ call save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP,&
+ static_memory_size,&
+ NGLOB1D_RADIAL_TEMP,&
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
+ NPROC_XI,NPROC_ETA, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
+
+ print *
+ print *,'edit file OUTPUT_FILES/values_from_mesher.h to see some statistics about the mesh'
+ print *
+
+ print *,'number of processors = ',NPROCTOT
+ print *
+ print *,'maximum number of points per region = ',nglob(IREGION_CRUST_MANTLE)
+ print *
+ print *,'total elements per slice = ',sum(NSPEC)
+ print *,'total points per slice = ',sum(nglob)
+ print *
+ print *,'number of time steps = ',NSTEP
+ print *
+
+ print *,'on NEC SX, make sure "loopcnt=" parameter'
+! use fused loops on NEC SX
+ print *,'in Makefile is greater than max vector length = ',nglob(IREGION_CRUST_MANTLE)*NDIM
+ print *
+
+ print *,'approximate static memory needed by the solver:'
+ print *,'----------------------------------------------'
+ print *
+ print *,'size of static arrays per slice = ',static_memory_size/1073741824.d0,' GB'
+ print *
+ print *,' (should be below and typically equal to 80% of 1.5 GB = 1.2 GB on pangu'
+ print *,' at Caltech, and below and typically equal to 85% of 2 GB = 1.7 GB'
+ print *,' on Marenostrum in Barcelona)'
+ print *,' (if significantly more, the job will not run by lack of memory)'
+ print *,' (if significantly less, you waste a significant amount of memory)'
+ print *
+ print *,'size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TB'
+ print *
+
+ end program xcreate_header_file
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_list_files_chunks.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_list_files_chunks.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_list_files_chunks.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_list_files_chunks.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,558 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 the list of messages to assemble between chunks in files if more than one chunk
+
+!! DK DK for merged version: a lot of useless code / useless lines car probably be suppressed
+!! DK DK in this new routine below
+
+ subroutine create_list_files_chunks(iregion_code, &
+ nglob_ori,NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_CORNER, &
+ myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS)
+
+ 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 "OUTPUT_FILES/values_from_mesher.h"
+
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
+
+ integer nglob,nglob_ori
+ integer NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_my_corner
+ integer myrank,NCHUNKS
+
+ character(len=150) OUTPUT_FILES
+
+! pairs generated theoretically
+! four sides for each of the three types of messages
+ integer, dimension(:), allocatable :: iproc_sender,iproc_receiver,npoin2D_send,npoin2D_receive
+
+! arrays to assemble the corners (3 processors for each corner)
+ integer, dimension(:,:), allocatable :: 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,iside,imode_comm,iedge
+
+ integer 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 **************
+
+! 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')
+
+! allocate arrays for faces
+ allocate(iproc_sender(NUMMSGS_FACES))
+ allocate(iproc_receiver(NUMMSGS_FACES))
+ allocate(npoin2D_send(NUMMSGS_FACES))
+ allocate(npoin2D_receive(NUMMSGS_FACES))
+
+! allocate array for corners
+ allocate(iprocscorners(3,NCORNERSCHUNKS))
+ allocate(itypecorner(3,NCORNERSCHUNKS))
+
+! clear arrays allocated
+ iproc_sender(:) = 0
+ iproc_receiver(:) = 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
+
+ if(myrank == 0) then
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! file to store the list of processors for each message for faces
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='unknown')
+
+ endif
+
+!!!!!!!!!! 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 = 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 == 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 == 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 == 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
+ iproc_sender(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
+ iproc_receiver(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
+
+! check that sender/receiver pair is ordered
+ if(iproc_sender(imsg) > iproc_receiver(imsg)) call exit_MPI(myrank,'incorrect order in sender/receiver pair')
+
+! save message type and pair of processors in list of messages
+ if(myrank == 0) write(IOUT,*) imsg_type,iproc_sender(imsg),iproc_receiver(imsg)
+
+! loop on sender/receiver (1=sender 2=receiver)
+ do imode_comm=1,2
+
+ if(imode_comm == 1) then
+ iproc = iproc_sender(imsg)
+ iedge = iproc_edge_send
+
+ else if(imode_comm == 2) then
+ iproc = iproc_receiver(imsg)
+ iedge = iproc_edge_receive
+
+ 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
+
+! 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
+
+! 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
+
+ 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
+!
+
+! synchronize all the processes to make sure all the buffers are ready
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+!!!!!!!!!! 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
+
+! file to store the list of processors for each message for corners
+ if(myrank == 0) open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='unknown')
+
+! 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
+ 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
+
+! 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
+
+! pick the correct 1D buffer
+! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
+ if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ else
+ call exit_MPI(myrank,'incorrect corner coordinates')
+ endif
+
+! end of section done only if right processor for MPI
+ endif
+
+ enddo
+
+ enddo
+
+ if(myrank == 0) close(IOUT)
+
+ end subroutine create_list_files_chunks
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_name_database.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_name_database.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_name_database.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_name_database.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,46 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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_name_database(prname,iproc,iregion_code,LOCAL_PATH)
+
+! create the name of the database for the mesher and the solver
+
+ implicit none
+
+ integer iproc,iregion_code
+
+! name of the database file
+ character(len=150) prname,procname,LOCAL_PATH
+
+! create the name for the database of the current slide and region
+ write(procname,"('/proc',i6.6,'_reg',i1,'_')") iproc,iregion_code
+
+! create full name with path
+ prname = trim(LOCAL_PATH) // procname
+
+ end subroutine create_name_database
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,2644 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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, &
+ NGLOB2DMAX_XY, &
+ myrank,LOCAL_PATH,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_region_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,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
+ 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,perm,invperm)
+
+! 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 "OUTPUT_FILES/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_region_has_a_doubling
+
+ integer :: ignod,ner_without_doubling,ispec_superbrick,ilayer,ilayer_loop,ix_elem,iy_elem,iz_elem, &
+ ifirst_region,ilast_region,ratio_divide_central_cube
+ integer, dimension(:), allocatable :: perm_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(:), pointer :: 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,HONOR_1D_SPHERICAL_MOHO
+
+ double precision R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+ character(len=150) LOCAL_PATH,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 and weights of integration
+ double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
+
+! 3D shape functions and their derivatives
+ double precision, dimension(:,:,:,:), allocatable :: shape3D
+ double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
+
+! 2D shape functions and their derivatives
+ double precision, dimension(:,:,:), allocatable :: shape2D_x,shape2D_y,shape2D_bottom,shape2D_top
+ double precision, dimension(:,:,:,:), allocatable :: dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top
+
+! 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,r1,r2,r3,r4,r5,r6,r7,r8
+
+! for model density and anisotropy
+ integer nspec_ani
+!! DK DK changed this for the merged version
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: 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(:,:,:,:), allocatable :: &
+ 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(:,:), allocatable :: 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(:), allocatable :: locval
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: 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(:), allocatable :: rmass_ocean_load
+
+! mask to sort ibool
+ integer, dimension(:), allocatable :: mask_ibool
+ integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
+ integer :: inumber
+
+! 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(:,:), allocatable :: iMPIcut_xi,iMPIcut_eta
+
+! Stacey, indices for Clayton-Engquist absorbing conditions
+ integer, dimension(:,:), allocatable :: nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
+
+! name of the database file
+ character(len=150) prname
+
+! 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(:,:,:,:), allocatable :: Qmu_store
+ double precision, dimension(:,:,:,:,:), allocatable :: 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,cpt,first_layer_aniso,last_layer_aniso,FIRST_ELT_NON_ANISO
+ double precision, dimension(:,:), allocatable :: stretch_tab
+
+ integer :: NGLOB2DMAX_XY
+
+ integer :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
+
+ 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)
+
+! now perform two passes in this part to be able to save memory
+ integer :: ipass
+
+! Boundary Mesh
+ integer nex_eta_moho
+ integer, dimension(:), allocatable :: ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
+ ibelm_670_top,ibelm_670_bot
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_moho,normal_400,normal_670
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_moho,jacobian2D_400,jacobian2D_670
+ integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot
+ double precision r_moho,r_400,r_670
+ logical :: is_superbrick
+
+! added for Cuthill McKee permutation
+! integer, dimension(:), allocatable :: perm,perm_tmp,temp_array_1D_int
+!! DK DK added this for merged version, as a quick patch
+ integer, dimension(nspec) :: perm,invperm
+ integer, dimension(:), allocatable :: perm_tmp,temp_array_1D_int
+ logical, dimension(:,:), allocatable :: temp_array_2D_log
+ integer, dimension(:,:,:,:), allocatable :: temp_array_int
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: temp_array_real
+ double precision, dimension(:,:,:,:), allocatable :: temp_array_dble
+ double precision, dimension(:,:,:,:,:), allocatable :: temp_array_dble_5dim
+!! DK DK added this for merged version
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: temp_array_xelm_yelm_zelm
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: temp_rmass
+
+! 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)
+
+! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+
+! Attenuation
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ T_c_source = AM_V%QT_c_source
+ tau_s(:) = AM_V%Qtau_s(:)
+ allocate(Qmu_store(NGLLX,NGLLY,NGLLZ,nspec),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
+
+ allocate(tau_e_store(N_SLS,NGLLX,NGLLY,NGLLZ,nspec),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
+ else
+ allocate(Qmu_store(1,1,1,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
+
+ allocate(tau_e_store(N_SLS,1,1,1,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
+
+ Qmu_store(1,1,1,1) = 0.0d0
+ tau_e_store(:,1,1,1,1) = 0.0d0
+ endif
+
+! Gauss-Lobatto-Legendre points of integration
+ allocate(xigll(NGLLX),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
+
+ allocate(yigll(NGLLY),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
+
+ allocate(zigll(NGLLZ),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
+
+! Gauss-Lobatto-Legendre weights of integration
+ allocate(wxgll(NGLLX),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
+
+ allocate(wygll(NGLLY),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
+
+ allocate(wzgll(NGLLZ),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
+
+! 3D shape functions and their derivatives
+ allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),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
+
+ allocate(dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ),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
+
+
+! 2D shape functions and their derivatives
+ allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ),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
+
+ allocate(shape2D_y(NGNOD2D,NGLLX,NGLLZ),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
+
+ allocate(shape2D_bottom(NGNOD2D,NGLLX,NGLLY),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
+
+ allocate(shape2D_top(NGNOD2D,NGLLX,NGLLY),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
+
+ allocate(dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),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
+
+ allocate(dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ),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
+
+ allocate(dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),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
+
+ allocate(dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY),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
+
+
+! array with model density
+!! DK DK changed this for the merged version
+ allocate(rhostore_local(NGLLX,NGLLY,NGLLZ),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
+
+!! DK DK added this for the merged version
+ allocate(kappavstore_local(NGLLX,NGLLY,NGLLZ),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
+
+
+! Stacey
+ if(NCHUNKS /= 6) then
+ nspec_stacey = nspec
+ else
+ nspec_stacey = 1
+ endif
+ allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey),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
+
+ allocate(rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey),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
+
+
+ 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
+
+ allocate(c11store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c12store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c13store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c14store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c15store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c16store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c22store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c23store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c24store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c25store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c26store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c33store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c34store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c35store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c36store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c44store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c45store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c46store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c55store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c56store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+ allocate(c66store(NGLLX,NGLLY,NGLLZ,nspec_ani),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
+
+
+! boundary locator
+ allocate(iboun(6,nspec),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
+
+
+! Stacey
+ allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX),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
+
+ allocate(nimax(2,NSPEC2DMAX_YMIN_YMAX),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
+
+ allocate(njmin(2,NSPEC2DMAX_XMIN_XMAX),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
+
+ allocate(njmax(2,NSPEC2DMAX_XMIN_XMAX),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
+
+ allocate(nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),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
+
+ allocate(nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX),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
+
+
+! MPI cut-planes parameters along xi and along eta
+ allocate(iMPIcut_xi(2,nspec),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
+
+ allocate(iMPIcut_eta(2,nspec),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
+
+
+! 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_region = 1
+ ilast_region = 10 + layer_shift
+
+ else if(iregion_code == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_shift
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+
+ else if(iregion_code == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+
+ else
+ call exit_MPI(myrank,'incorrect region code detected')
+
+ endif
+
+! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
+ if (ONE_CRUST) then
+ first_layer_aniso=2
+ last_layer_aniso=3
+ nb_layer_above_aniso = 1
+ else
+ first_layer_aniso=3
+ last_layer_aniso=4
+ nb_layer_above_aniso = 2
+ endif
+ allocate (perm_layer(ifirst_region:ilast_region),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
+
+ perm_layer = (/ (i, i=ilast_region,ifirst_region,-1) /)
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ cpt=3
+ perm_layer(1)=first_layer_aniso
+ perm_layer(2)=last_layer_aniso
+ do i = ilast_region,ifirst_region,-1
+ if (i/=first_layer_aniso .and. i/=last_layer_aniso) then
+ perm_layer(cpt) = i
+ cpt=cpt+1
+ endif
+ 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
+
+! boundary mesh
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ allocate(ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO),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
+
+ allocate(ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400),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
+
+ allocate(ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670),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
+
+ allocate(normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO),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
+
+ allocate(normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400),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
+
+ allocate(normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670),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
+
+ allocate(jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO),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
+
+ allocate(jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400),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
+
+ allocate(jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670),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
+
+
+ ispec2D_moho_top = 0; ispec2D_moho_bot = 0
+ ispec2D_400_top = 0; ispec2D_400_bot = 0
+ ispec2D_670_top = 0; ispec2D_670_bot = 0
+
+ nex_eta_moho = NEX_PER_PROC_ETA
+
+ r_moho = RMOHO/R_EARTH; r_400 = R400 / R_EARTH; r_670 = R670/R_EARTH
+
+ 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_region,ilast_region
+
+ ilayer = perm_layer(ilayer_loop)
+
+! determine the radii that define the shell
+ rmin = rmins(ilayer)
+ rmax = rmaxs(ilayer)
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==3) then
+ FIRST_ELT_NON_ANISO = ispec+1
+ endif
+ if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==(ilast_region-nb_layer_above_aniso+1)) then
+ FIRST_ELT_ABOVE_ANISO = ispec+1
+ endif
+
+ 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_region_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_region) then
+ iboun(6,ispec)= .true.
+ endif
+ if (iz_elem == 1 .and. ilayer == ilast_region) 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)
+
+! save the radii of the nodes before modified through compute_element_properties()
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ r1=sqrt(xelm(1)**2+yelm(1)**2+zelm(1)**2)
+ r2=sqrt(xelm(2)**2+yelm(2)**2+zelm(2)**2)
+ r3=sqrt(xelm(3)**2+yelm(3)**2+zelm(3)**2)
+ r4=sqrt(xelm(4)**2+yelm(4)**2+zelm(4)**2)
+ r5=sqrt(xelm(5)**2+yelm(5)**2+zelm(5)**2)
+ r6=sqrt(xelm(6)**2+yelm(6)**2+zelm(6)**2)
+ r7=sqrt(xelm(7)**2+yelm(7)**2+zelm(7)**2)
+ r8=sqrt(xelm(8)**2+yelm(8)**2+zelm(8)**2)
+ 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"
+
+! boundary mesh
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ is_superbrick=.false.
+ ispec_superbrick=0
+ call get_jacobian_discontinuities(myrank,ispec,ix_elem,iy_elem,rmin,rmax,r1,r2,r3,r4,r5,r6,r7,r8, &
+ xstore(:,:,:,ispec),ystore(:,:,:,ispec),zstore(:,:,:,ispec),dershape2D_bottom, &
+ ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
+ normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
+ ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
+ NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,r_moho,r_400,r_670, &
+ is_superbrick,USE_ONE_LAYER_SB,ispec_superbrick,nex_eta_moho,HONOR_1D_SPHERICAL_MOHO)
+ endif
+
+! 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_region_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_region .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 & 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 & 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_region) then
+ iboun(6,ispec)= iboun_sb(ispec_superbrick,6)
+ endif
+ if (ilayer==ilast_region .and. iz_elem==1) then
+ iboun(5,ispec)= iboun_sb(ispec_superbrick,5)
+ endif
+
+! define the doubling flag of this element
+ if(iregion_code /= IREGION_OUTER_CORE) idoubling(ispec) = doubling_index(ilayer)
+
+! save the radii of the nodes before modified through compute_element_properties()
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ r1=sqrt(xelm(1)**2+yelm(1)**2+zelm(1)**2)
+ r2=sqrt(xelm(2)**2+yelm(2)**2+zelm(2)**2)
+ r3=sqrt(xelm(3)**2+yelm(3)**2+zelm(3)**2)
+ r4=sqrt(xelm(4)**2+yelm(4)**2+zelm(4)**2)
+ r5=sqrt(xelm(5)**2+yelm(5)**2+zelm(5)**2)
+ r6=sqrt(xelm(6)**2+yelm(6)**2+zelm(6)**2)
+ r7=sqrt(xelm(7)**2+yelm(7)**2+zelm(7)**2)
+ r8=sqrt(xelm(8)**2+yelm(8)**2+zelm(8)**2)
+ 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"
+
+! boundary mesh
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ is_superbrick=.true.
+ call get_jacobian_discontinuities(myrank,ispec,ix_elem,iy_elem,rmin,rmax,r1,r2,r3,r4,r5,r6,r7,r8, &
+ xstore(:,:,:,ispec),ystore(:,:,:,ispec),zstore(:,:,:,ispec),dershape2D_bottom, &
+ ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
+ normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
+ ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
+ NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,r_moho,r_400,r_670, &
+ is_superbrick,USE_ONE_LAYER_SB,ispec_superbrick,nex_eta_moho,HONOR_1D_SPHERICAL_MOHO)
+ endif
+
+! 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
+ endif
+
+ endif
+ deallocate (perm_layer,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate perm_layer in create_regions_mesh ier=",ier
+ 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
+
+ ! allocate memory for arrays
+ allocate(locval(npointot),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
+
+ allocate(ifseg(npointot),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
+
+ allocate(xp(npointot),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
+
+ allocate(yp(npointot),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
+
+ allocate(zp(npointot),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
+
+ 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)
+
+ deallocate(xp,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate xp in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(yp,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate yp in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(zp,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate zp in create_regions_mesh ier=",ier
+ endif
+
+
+ ! 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
+ allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate copy_ibool_ori in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(mask_ibool(nglob),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate mask_ibool in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ 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
+
+ deallocate(copy_ibool_ori,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate copy_ibool_ori in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(mask_ibool,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate mask_ibool in create_regions_mesh ier=",ier
+ endif
+
+
+ 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, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC2D_ETA_FACE,iregion_code,NGLOB2DMAX_XY,nglob,iboolleft_xi,iboolright_xi,NGLOB2DMAX_XMIN_XMAX,npoin2D_xi)
+ call get_MPI_cutplanes_eta(myrank,nspec,iMPIcut_eta,ibool, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC2D_XI_FACE,iregion_code,NGLOB2DMAX_XY,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)
+
+ deallocate(locval,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate locval in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(ifseg,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate ifseg in create_regions_mesh ier=",ier
+ endif
+
+!! DK DK for merged code, copied here to be able to create mass matrix in right order
+ if (PERFORM_CUTHILL_MCKEE) then
+!!!!!!!!!!!!!!!!!!!! allocate(perm(nspec))
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ ! do not permute anisotropic elements
+ perm(1:FIRST_ELT_NON_ANISO-1) = (/ (i,i=1,FIRST_ELT_NON_ANISO-1) /)
+
+ ! no more connectivity between layers below and above the anisotropic layers => 2 permutations
+ ! permute the bottom of the region : below the aniso layers
+ allocate(perm_tmp(FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate perm_tmp in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ call get_perm(ibool(:,:,:,FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1),perm_tmp,LIMIT_MULTI_CUTHILL,&
+ (FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO),nglob,.true.,.false.)
+ perm(FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1) = perm_tmp(:)+(FIRST_ELT_NON_ANISO-1)
+ deallocate(perm_tmp,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate perm_tmp in create_regions_mesh ier=",ier
+ endif
+
+ ! permute the top of the region : above the aniso layers
+ allocate(perm_tmp(nspec-FIRST_ELT_ABOVE_ANISO+1),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate perm_tmp in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ call get_perm(ibool(:,:,:,FIRST_ELT_ABOVE_ANISO:nspec),perm_tmp,LIMIT_MULTI_CUTHILL,&
+ (nspec-FIRST_ELT_ABOVE_ANISO+1),nglob,.true.,.false.)
+ perm(FIRST_ELT_ABOVE_ANISO:nspec) = perm_tmp(:)+(FIRST_ELT_ABOVE_ANISO-1)
+ deallocate(perm_tmp,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate perm_tmp in create_regions_mesh ier=",ier
+ endif
+ else
+ ! the 3 last parameters are : PERFORM_CUTHILL_MCKEE,INVERSE,FACE
+ call get_perm(ibool,perm,LIMIT_MULTI_CUTHILL,nspec,nglob,.true.,.false.)
+ endif
+!!!!!!!!!!!!!!!!!!!! deallocate(perm)
+!! DK DK create inverse permutation
+ if(minval(perm) /= 1) stop 'minval of perm must be 1'
+ if(maxval(perm) /= nspec) stop 'maxval of perm must be nspec'
+ invperm(:) = -1
+ do ispec=1,nspec
+ if(invperm(perm(ispec)) == -1) then
+ invperm(perm(ispec)) = ispec
+ else
+ stop 'value already found, permutation is not bijective'
+ endif
+ enddo
+ if(minval(invperm) /= 1) stop 'minval of invperm must be 1'
+ if(maxval(invperm) /= nspec) stop 'maxval of invperm must be nspec'
+ endif
+!! DK DK for merged code, copied here to be able to create mass matrix in right order
+
+! 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
+
+! ***************************************************
+! Cuthill McKee permutation
+! ***************************************************
+ if (PERFORM_CUTHILL_MCKEE) then
+!!!!!!!!!!!!!!!!!!! allocate(perm(nspec))
+! if(iregion_code == IREGION_CRUST_MANTLE) then
+! ! do not permute anisotropic elements
+! perm(1:FIRST_ELT_NON_ANISO-1) = (/ (i,i=1,FIRST_ELT_NON_ANISO-1) /)
+
+! ! no more connectivity between layers below and above the anisotropic layers => 2 permutations
+! ! permute the bottom of the region : below the aniso layers
+! allocate(perm_tmp(FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO))
+! call get_perm(ibool(:,:,:,FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1),perm_tmp,LIMIT_MULTI_CUTHILL,&
+! (FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO),nglob,.true.,.false.)
+! perm(FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1) = perm_tmp(:)+(FIRST_ELT_NON_ANISO-1)
+! deallocate(perm_tmp)
+
+! ! permute the top of the region : above the aniso layers
+! allocate(perm_tmp(nspec-FIRST_ELT_ABOVE_ANISO+1))
+! call get_perm(ibool(:,:,:,FIRST_ELT_ABOVE_ANISO:nspec),perm_tmp,LIMIT_MULTI_CUTHILL,&
+! (nspec-FIRST_ELT_ABOVE_ANISO+1),nglob,.true.,.false.)
+! perm(FIRST_ELT_ABOVE_ANISO:nspec) = perm_tmp(:)+(FIRST_ELT_ABOVE_ANISO-1)
+! deallocate(perm_tmp)
+! else
+! ! the 3 last parameters are : PERFORM_CUTHILL_MCKEE,INVERSE,FACE
+! call get_perm(ibool,perm,LIMIT_MULTI_CUTHILL,nspec,nglob,.true.,.false.)
+! endif
+
+ ! permutation of xstore, ystore, zstore, rhostore, kappavstore, kappahstore,
+ ! muvstore, muhstore, eta_anisostore
+
+ allocate(temp_array_dble(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_dble in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ call permute_elements_dble(Qmu_store,temp_array_dble,perm,nspec)
+ allocate(temp_array_dble_5dim(N_SLS,NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate permute_elements_dble in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ temp_array_dble_5dim(:,:,:,:,:) = tau_e_store(:,:,:,:,:)
+ do i = 1,nspec
+ tau_e_store(:,:,:,:,perm(i)) = temp_array_dble_5dim(:,:,:,:,i)
+ enddo
+ deallocate(temp_array_dble_5dim,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_dble_5dim in create_regions_mesh ier=",ier
+ endif
+
+ endif
+ call permute_elements_dble(xstore,temp_array_dble,perm,nspec)
+ call permute_elements_dble(ystore,temp_array_dble,perm,nspec)
+ call permute_elements_dble(zstore,temp_array_dble,perm,nspec)
+ deallocate(temp_array_dble,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_dble in create_regions_mesh ier=",ier
+ endif
+
+!! DK DK added this for merged code
+ allocate(temp_array_xelm_yelm_zelm(NGNOD,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_xelm_yelm_zelm in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ call permute_elements_xelm_yelm_zelm(xelm_store,temp_array_xelm_yelm_zelm,perm,nspec)
+ call permute_elements_xelm_yelm_zelm(yelm_store,temp_array_xelm_yelm_zelm,perm,nspec)
+ call permute_elements_xelm_yelm_zelm(zelm_store,temp_array_xelm_yelm_zelm,perm,nspec)
+
+ deallocate(temp_array_xelm_yelm_zelm,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_xelm_yelm_zelm in create_regions_mesh ier=",ier
+ endif
+
+ allocate(temp_array_real(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_real in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS /= 6) then
+ call permute_elements_real(rho_vp,temp_array_real,perm,nspec)
+ call permute_elements_real(rho_vs,temp_array_real,perm,nspec)
+ endif
+ if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
+ (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) then
+ call permute_elements_real(c11store,temp_array_real,perm,nspec)
+ call permute_elements_real(c12store,temp_array_real,perm,nspec)
+ call permute_elements_real(c13store,temp_array_real,perm,nspec)
+ call permute_elements_real(c14store,temp_array_real,perm,nspec)
+ call permute_elements_real(c15store,temp_array_real,perm,nspec)
+ call permute_elements_real(c16store,temp_array_real,perm,nspec)
+ call permute_elements_real(c22store,temp_array_real,perm,nspec)
+ call permute_elements_real(c23store,temp_array_real,perm,nspec)
+ call permute_elements_real(c24store,temp_array_real,perm,nspec)
+ call permute_elements_real(c25store,temp_array_real,perm,nspec)
+ call permute_elements_real(c26store,temp_array_real,perm,nspec)
+ call permute_elements_real(c33store,temp_array_real,perm,nspec)
+ call permute_elements_real(c34store,temp_array_real,perm,nspec)
+ call permute_elements_real(c35store,temp_array_real,perm,nspec)
+ call permute_elements_real(c36store,temp_array_real,perm,nspec)
+ call permute_elements_real(c44store,temp_array_real,perm,nspec)
+ call permute_elements_real(c45store,temp_array_real,perm,nspec)
+ call permute_elements_real(c46store,temp_array_real,perm,nspec)
+ call permute_elements_real(c55store,temp_array_real,perm,nspec)
+ call permute_elements_real(c56store,temp_array_real,perm,nspec)
+ call permute_elements_real(c66store,temp_array_real,perm,nspec)
+ endif
+!! DK DK added this for merged version
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ call permute_elements_real(kappavstore,temp_array_real,perm,nspec)
+ call permute_elements_real(muvstore,temp_array_real,perm,nspec)
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) then
+ if(minval(perm(1:NSPECMAX_TISO_MANTLE)) /= 1) stop 'minval perm for aniso should be 1'
+ if(maxval(perm(1:NSPECMAX_TISO_MANTLE)) /= NSPECMAX_TISO_MANTLE) &
+ stop 'maxval perm for aniso should be NSPECMAX_TISO_MANTLE'
+ call permute_elements_real(kappahstore,temp_array_real,perm,NSPECMAX_TISO_MANTLE)
+ call permute_elements_real(muhstore,temp_array_real,perm,NSPECMAX_TISO_MANTLE)
+ call permute_elements_real(eta_anisostore,temp_array_real,perm,NSPECMAX_TISO_MANTLE)
+ endif
+ endif
+
+!! DK DK added this for merged version: attempt to permute mass matrix
+! 333333333333333
+ allocate(temp_rmass(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_rmass in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! allocate(temp_rmass(nglob))
+ do ispec = 1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+! temp_rmass(ibool(i,j,k,perm(ispec))) = rmass(ibool(i,j,k,ispec))
+ temp_rmass(i,j,k,ispec) = rmass(ibool(i,j,k,ispec))
+ enddo
+ enddo
+ enddo
+ enddo
+! rmass(:) = temp_rmass(:)
+ call permute_elements_real(temp_rmass,temp_array_real,perm,nspec)
+! do ispec = 1,nspec
+! do k = 1,NGLLZ
+! do j = 1,NGLLY
+! do i = 1,NGLLX
+! rmass(ibool(i,j,k,ispec)) = temp_rmass(i,j,k,ispec)
+! enddo
+! enddo
+! enddo
+! enddo
+! deallocate(temp_rmass)
+
+ deallocate(temp_array_real,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_real in create_regions_mesh ier=",ier
+ endif
+
+ ! permutation of ibool
+ allocate(temp_array_int(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_int in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ call permute_elements_integer(ibool,temp_array_int,perm,nspec)
+ deallocate(temp_array_int,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_int in create_regions_mesh ier=",ier
+ endif
+
+!! DK DK added this for merged version: attempt to permute mass matrix
+! 333333333333333
+ do ispec = 1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ rmass(ibool(i,j,k,ispec)) = temp_rmass(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ deallocate(temp_rmass,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_rmass in create_regions_mesh ier=",ier
+ endif
+
+! deallocate(temp_array_real)
+
+ ! permutation of iMPIcut_*
+ allocate(temp_array_2D_log(2,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_2D_log in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ temp_array_2D_log(:,:) = iMPIcut_xi(:,:)
+ do i = 1,nspec
+ iMPIcut_xi(:,perm(i)) = temp_array_2D_log(:,i)
+ enddo
+ temp_array_2D_log(:,:) = iMPIcut_eta(:,:)
+ do i = 1,nspec
+ iMPIcut_eta(:,perm(i)) = temp_array_2D_log(:,i)
+ enddo
+
+ deallocate(temp_array_2D_log,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_2D_log in create_regions_mesh ier=",ier
+ endif
+
+ ! permutation of iboun
+ allocate(temp_array_2D_log(6,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_2D_log in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ temp_array_2D_log(:,:) = iboun(:,:)
+ do i = 1,nspec
+ iboun(:,perm(i)) = temp_array_2D_log(:,i)
+ enddo
+
+ deallocate(temp_array_2D_log,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_2D_log in create_regions_mesh ier=",ier
+ endif
+
+
+ ! permutation of idoubling
+!! DK DK added this for merged version because array not allocated in the outer core
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ allocate(temp_array_1D_int(nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_1D_int in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ temp_array_1D_int(:) = idoubling(:)
+ do i = 1,nspec
+ idoubling(perm(i)) = temp_array_1D_int(i)
+ enddo
+ deallocate(temp_array_1D_int,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_1D_int in create_regions_mesh ier=",ier
+ endif
+ endif
+
+!!!!!!!!!!!!!!!!!!! deallocate(perm)
+ endif
+
+! ***************************************************
+! end of Cuthill McKee permutation
+! ***************************************************
+
+ 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
+ allocate(rmass_ocean_load(nglob_oceans),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate rmass_ocean_load in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! 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)
+
+! compute local height of oceans
+ if(ISOTROPIC_3D_MANTLE) 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
+ 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
+ allocate(rmass_ocean_load(nglob_oceans),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate rmass_ocean_load in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ endif
+
+! save the binary files
+!! DK DK MERGED UGLY this is the only thing we are going to have to save
+! call save_arrays_solver(rho_vp,rho_vs,nspec_stacey, &
+! prname,iregion_code,xixstore,xiystore,xizstore, &
+! etaxstore,etaystore,etazstore, &
+! gammaxstore,gammaystore,gammazstore, &
+! xstore,ystore,zstore, rhostore, &
+! kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+! nspec_ani, &
+! c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+! c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+! c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+! ibool,idoubling,rmass,rmass_ocean_load,nglob_oceans, &
+! ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+! nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+! normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
+! jacobian2D_xmin,jacobian2D_xmax, &
+! jacobian2D_ymin,jacobian2D_ymax, &
+! jacobian2D_bottom,jacobian2D_top, &
+! nspec,nglob, &
+! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+! TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS, &
+! tau_s,tau_e_store,Qmu_store,T_c_source, &
+! ATTENUATION,ATTENUATION_3D, &
+! size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5),&
+! NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NEX_XI,ichunk,NCHUNKS,ABSORBING_CONDITIONS,AM_V)
+
+! boundary mesh
+ if (SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+! first check the number of surface elements are the same for Moho, 400, 670
+ if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
+ if (ispec2D_moho_top /= NSPEC2D_MOHO .or. ispec2D_moho_bot /= NSPEC2D_MOHO) &
+ call exit_mpi(myrank, 'Not the same number of Moho surface elements')
+ endif
+ if (ispec2D_400_top /= NSPEC2D_400 .or. ispec2D_400_bot /= NSPEC2D_400) &
+ call exit_mpi(myrank,'Not the same number of 400 surface elements')
+ if (ispec2D_670_top /= NSPEC2D_670 .or. ispec2D_670_bot /= NSPEC2D_670) &
+ call exit_mpi(myrank,'Not the same number of 670 surface elements')
+
+! writing surface topology databases
+ open(unit=27,file=prname(1:len_trim(prname))//'boundary_disc.bin',status='unknown',form='unformatted')
+ write(27) NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670
+ write(27) ibelm_moho_top
+ write(27) ibelm_moho_bot
+ write(27) ibelm_400_top
+ write(27) ibelm_400_bot
+ write(27) ibelm_670_top
+ write(27) ibelm_670_bot
+ write(27) normal_moho
+ write(27) normal_400
+ write(27) normal_670
+ close(27)
+
+ deallocate(ibelm_moho_top,ibelm_moho_bot,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate ibelm_moho_top in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(ibelm_400_top,ibelm_400_bot,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate ibelm_400_top in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(ibelm_670_top,ibelm_670_bot,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate ibelm_670_top,ibelm_670_bot in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(normal_moho,normal_400,normal_670,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate normal_moho,normal_400,normal_670 in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(jacobian2D_moho,jacobian2D_400,jacobian2D_670,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate jacobian2D_moho,jacobian2D_400,jacobian2D_670 in create_regions_mesh ier=",ier
+ endif
+
+ endif
+
+! 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 for 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 for 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
+
+! deallocate arrays
+ deallocate(rhostore_local,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate rhostore_local in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(kappavstore_local,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate kappavstore_local in create_regions_mesh ier=",ier
+ endif
+
+
+ deallocate(c11store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c11store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c12store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c12store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c13store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c13store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c14store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c14store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c15store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c15store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c16store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c16store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c22store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c22store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c23store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c23store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c24store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c24store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c25store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c25store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c26store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c26store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c33store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c33store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c34store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c34store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c35store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c35store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c36store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c36store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c44store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c44store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c45store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c45store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c46store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c46store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c55store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c55store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c56store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c56store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c66store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c66store in create_regions_mesh ier=",ier
+ endif
+
+
+ deallocate(iboun,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate iboun in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(xigll,yigll,zigll,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate xigll,yigll,zigll in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(wxgll,wygll,wzgll,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate wxgll,wygll,wzgll in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(shape3D,dershape3D,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate shape3D,dershape3D in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(shape2D_x,shape2D_y,shape2D_bottom,shape2D_top,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate shape2D_x,shape2D_y,shape2D_bottom,shape2D_top in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top" &
+ ," in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(iMPIcut_xi,iMPIcut_eta,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate iMPIcut_xi,iMPIcut_eta in create_regions_mesh ier=",ier
+ endif
+
+
+ deallocate(nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta ",&
+ "in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(rho_vp,rho_vs,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate rho_vp,rho_vs in create_regions_mesh ier=",ier
+ endif
+
+
+ deallocate(Qmu_store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate Qmu_store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(tau_e_store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate tau_e_store in create_regions_mesh ier=",ier
+ endif
+
+ if (allocated(rmass_ocean_load) ) then
+ deallocate(rmass_ocean_load,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate rmass_ocean_load in create_regions_mesh ier=",ier
+ endif
+ endif
+
+
+ end subroutine create_regions_mesh
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/crustal_model.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/crustal_model.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/crustal_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/crustal_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,367 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+!
+! read and smooth crust2.0 model
+! based on software routines provided with the crust2.0 model by Bassin et al.
+!
+
+ subroutine crustal_model(lat,lon,x,vp,vs,rho,moho,found_crust,CM_V)
+
+ implicit none
+ include "constants.h"
+
+! 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
+
+ double precision lat,lon,x,vp,vs,rho,moho
+ logical found_crust
+
+ double precision h_sed,h_uc
+ double precision x3,x4,x5,x6,x7,scaleval
+ double precision vps(NLAYERS_CRUST),vss(NLAYERS_CRUST),rhos(NLAYERS_CRUST),thicks(NLAYERS_CRUST)
+
+ call crust(lat,lon,vps,vss,rhos,thicks,CM_V%abbreviation,CM_V%code,CM_V%thlr,CM_V%velocp,CM_V%velocs,CM_V%dens)
+
+ x3 = (R_EARTH-thicks(3)*1000.0d0)/R_EARTH
+ h_sed = thicks(3) + thicks(4)
+ x4 = (R_EARTH-h_sed*1000.0d0)/R_EARTH
+ h_uc = h_sed + thicks(5)
+ x5 = (R_EARTH-h_uc*1000.0d0)/R_EARTH
+ x6 = (R_EARTH-(h_uc+thicks(6))*1000.0d0)/R_EARTH
+ x7 = (R_EARTH-(h_uc+thicks(6)+thicks(7))*1000.0d0)/R_EARTH
+
+ found_crust = .true.
+ if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST) then
+ vp = vps(3)
+ vs = vss(3)
+ rho = rhos(3)
+ else if(x > x4 .and. INCLUDE_SEDIMENTS_CRUST) then
+ vp = vps(4)
+ vs = vss(4)
+ rho = rhos(4)
+ else if(x > x5) then
+ vp = vps(5)
+ vs = vss(5)
+ rho = rhos(5)
+ else if(x > x6) then
+ vp = vps(6)
+ vs = vss(6)
+ rho = rhos(6)
+ else if(x > x7) then
+ vp = vps(7)
+ vs = vss(7)
+ rho = rhos(7)
+ else
+ found_crust = .false.
+ endif
+
+ if (found_crust) then
+! non-dimensionalize
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+ vp = vp*1000.0d0/(R_EARTH*scaleval)
+ vs = vs*1000.0d0/(R_EARTH*scaleval)
+ rho = rho*1000.0d0/RHOAV
+ moho = (h_uc+thicks(6)+thicks(7))*1000.0d0/R_EARTH
+ endif
+
+ end subroutine crustal_model
+
+!---------------------------
+
+ subroutine read_crustal_model(CM_V)
+
+ implicit none
+ include "constants.h"
+
+! 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
+
+! local variables
+ integer i
+ integer ila,icolat
+ integer ikey
+
+ double precision h_moho_min,h_moho_max
+
+ character(len=150) CNtype2, CNtype2_key_modif
+
+ call get_value_string(CNtype2, 'model.CNtype2', 'DATA/crust2.0/CNtype2.txt')
+ call get_value_string(CNtype2_key_modif, 'model.CNtype2_key_modif', 'DATA/crust2.0/CNtype2_key_modif.txt')
+
+ open(unit=1,file=CNtype2,status='old',action='read')
+ do ila=1,NCAP_CRUST/2
+ read(1,*) icolat,(CM_V%abbreviation(ila,i),i=1,NCAP_CRUST)
+ enddo
+ close(1)
+
+ open(unit=1,file=CNtype2_key_modif,status='old',action='read')
+ h_moho_min=HUGEVAL
+ h_moho_max=-HUGEVAL
+ do ikey=1,NKEYS_CRUST
+ read (1,"(a2)") CM_V%code(ikey)
+ read (1,*) (CM_V%velocp(ikey,i),i=1,NLAYERS_CRUST)
+ read (1,*) (CM_V%velocs(ikey,i),i=1,NLAYERS_CRUST)
+ read (1,*) (CM_V%dens(ikey,i),i=1,NLAYERS_CRUST)
+ read (1,*) (CM_V%thlr(ikey,i),i=1,NLAYERS_CRUST-1),CM_V%thlr(ikey,NLAYERS_CRUST)
+ if(CM_V%thlr(ikey,NLAYERS_CRUST) > h_moho_max) h_moho_max=CM_V%thlr(ikey,NLAYERS_CRUST)
+ if(CM_V%thlr(ikey,NLAYERS_CRUST) < h_moho_min) h_moho_min=CM_V%thlr(ikey,NLAYERS_CRUST)
+ enddo
+ close(1)
+
+ if(h_moho_min == HUGEVAL .or. h_moho_max == -HUGEVAL) &
+ stop 'incorrect moho depths in read_3D_crustal_model'
+
+ end subroutine read_crustal_model
+
+!---------------------------
+
+ subroutine crust(lat,lon,velp,vels,rho,thick,abbreviation,code,thlr,velocp,velocs,dens)
+
+! crustal vp and vs in km/s, layer thickness in km
+! crust2.0 is smoothed with a cap of size CAP using NTHETA points
+! in the theta direction and NPHI in the phi direction.
+! The cap is rotated to the North Pole.
+
+ implicit none
+ include "constants.h"
+
+ integer, parameter :: NTHETA = 2
+ integer, parameter :: NPHI = 10
+ double precision, parameter :: CAP = 2.0d0*PI/180.0d0
+
+! argument variables
+ double precision lat,lon
+ double precision rho(NLAYERS_CRUST),thick(NLAYERS_CRUST),velp(NLAYERS_CRUST),vels(NLAYERS_CRUST)
+ double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
+ double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
+ character(len=2) code(NKEYS_CRUST),abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+
+! local variables
+ integer i,j,k,icolat,ilon,ierr
+ integer itheta,iphi,npoints
+ double precision theta,phi,sint,cost,sinp,cosp,dtheta,dphi,cap_area,wght,total
+ double precision r_rot,theta_rot,phi_rot
+ double precision rotation_matrix(3,3),x(3),xc(3)
+ double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
+ double precision rhol(NLAYERS_CRUST),thickl(NLAYERS_CRUST),velpl(NLAYERS_CRUST),velsl(NLAYERS_CRUST)
+ character(len=2) crustaltype
+
+! get integer colatitude and longitude of crustal cap
+! -90<lat<90 -180<lon<180
+ if(lat > 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) &
+ stop 'error in latitude/longitude range in crust'
+ if(lat==90.0d0) lat=89.9999d0
+ if(lat==-90.0d0) lat=-89.9999d0
+ if(lon==180.0d0) lon=179.9999d0
+ if(lon==-180.0d0) lon=-179.9999d0
+
+ call icolat_ilon(lat,lon,icolat,ilon)
+ crustaltype=abbreviation(icolat,ilon)
+ call get_crust_structure(crustaltype,velp,vels,rho,thick, &
+ code,thlr,velocp,velocs,dens,ierr)
+
+! uncomment the following line to use crust2.0 as is, without smoothing
+!
+! return
+
+ theta = (90.0-lat)*PI/180.0
+ phi = lon*PI/180.0
+
+ sint = sin(theta)
+ cost = cos(theta)
+ sinp = sin(phi)
+ cosp = cos(phi)
+
+! set up rotation matrix to go from cap at North pole
+! to cap around point of interest
+ rotation_matrix(1,1) = cosp*cost
+ rotation_matrix(1,2) = -sinp
+ rotation_matrix(1,3) = cosp*sint
+ rotation_matrix(2,1) = sinp*cost
+ rotation_matrix(2,2) = cosp
+ rotation_matrix(2,3) = sinp*sint
+ rotation_matrix(3,1) = -sint
+ rotation_matrix(3,2) = 0.0
+ rotation_matrix(3,3) = cost
+
+ dtheta = CAP/dble(NTHETA)
+ dphi = 2.0*PI/dble(NPHI)
+ cap_area = 2.0*PI*(1.0-cos(CAP))
+
+! integrate over a cap at the North pole
+ i = 0
+ total = 0.0
+ do itheta = 1,NTHETA
+
+ theta = 0.5*dble(2*itheta-1)*CAP/dble(NTHETA)
+ cost = cos(theta)
+ sint = sin(theta)
+ wght = sint*dtheta*dphi/cap_area
+
+ do iphi = 1,NPHI
+
+ i = i+1
+! get the weight associated with this integration point (same for all phi)
+ weight(i) = wght
+ total = total + weight(i)
+ phi = dble(2*iphi-1)*PI/dble(NPHI)
+ cosp = cos(phi)
+ sinp = sin(phi)
+! x,y,z coordinates of integration point in cap at North pole
+ xc(1) = sint*cosp
+ xc(2) = sint*sinp
+ xc(3) = cost
+! get x,y,z coordinates in cap around point of interest
+ do j=1,3
+ x(j) = 0.0
+ do k=1,3
+ x(j) = x(j)+rotation_matrix(j,k)*xc(k)
+ enddo
+ enddo
+! get latitude and longitude (degrees) of integration point
+ call xyz_2_rthetaphi_dble(x(1),x(2),x(3),r_rot,theta_rot,phi_rot)
+ call reduce(theta_rot,phi_rot)
+ xlat(i) = (PI/2.0-theta_rot)*180.0/PI
+ xlon(i) = phi_rot*180.0/PI
+ if(xlon(i) > 180.0) xlon(i) = xlon(i)-360.0
+
+ enddo
+
+ enddo
+
+ if(abs(total-1.0) > 0.001) stop 'error in cap integration for crust2.0'
+
+ npoints = i
+
+ do j=1,NLAYERS_CRUST
+ rho(j)=0.0d0
+ thick(j)=0.0d0
+ velp(j)=0.0d0
+ vels(j)=0.0d0
+ enddo
+
+ do i=1,npoints
+ call icolat_ilon(xlat(i),xlon(i),icolat,ilon)
+ crustaltype=abbreviation(icolat,ilon)
+ call get_crust_structure(crustaltype,velpl,velsl,rhol,thickl, &
+ code,thlr,velocp,velocs,dens,ierr)
+ if(ierr /= 0) stop 'error in routine get_crust_structure'
+ do j=1,NLAYERS_CRUST
+ rho(j)=rho(j)+weight(i)*rhol(j)
+ thick(j)=thick(j)+weight(i)*thickl(j)
+ velp(j)=velp(j)+weight(i)*velpl(j)
+ vels(j)=vels(j)+weight(i)*velsl(j)
+ enddo
+ enddo
+
+ end subroutine crust
+
+!------------------------------------------------------
+
+ subroutine icolat_ilon(xlat,xlon,icolat,ilon)
+
+ implicit none
+
+
+! argument variables
+ double precision xlat,xlon
+ integer icolat,ilon
+
+ if(xlat > 90.0d0 .or. xlat < -90.0d0 .or. xlon > 180.0d0 .or. xlon < -180.0d0) &
+ stop 'error in latitude/longitude range in icolat_ilon'
+ icolat=int(1+((90.d0-xlat)/2.d0))
+ if(icolat == 91) icolat=90
+ ilon=int(1+((180.d0+xlon)/2.d0))
+ if(ilon == 181) ilon=1
+
+ if(icolat>90 .or. icolat<1) stop 'error in routine icolat_ilon'
+ if(ilon<1 .or. ilon>180) stop 'error in routine icolat_ilon'
+
+ end subroutine icolat_ilon
+
+!---------------------------------------------------------------------
+
+ subroutine get_crust_structure(type,vptyp,vstyp,rhtyp,thtp, &
+ code,thlr,velocp,velocs,dens,ierr)
+
+ implicit none
+ include "constants.h"
+
+
+! argument variables
+ integer ierr
+ double precision rhtyp(NLAYERS_CRUST),thtp(NLAYERS_CRUST)
+ double precision vptyp(NLAYERS_CRUST),vstyp(NLAYERS_CRUST)
+ character(len=2) type,code(NKEYS_CRUST)
+ double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
+ double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
+
+! local variables
+ integer i,ikey
+
+ ierr=1
+ do ikey=1,NKEYS_CRUST
+ if (code(ikey) == type) then
+ do i=1,NLAYERS_CRUST
+ vptyp(i)=velocp(ikey,i)
+ vstyp(i)=velocs(ikey,i)
+ rhtyp(i)=dens(ikey,i)
+ enddo
+ do i=1,NLAYERS_CRUST-1
+ thtp(i)=thlr(ikey,i)
+ enddo
+! get distance to Moho from the bottom of the ocean or the ice
+ thtp(NLAYERS_CRUST)=thlr(ikey,NLAYERS_CRUST)-thtp(1)-thtp(2)
+ ierr=0
+ endif
+ enddo
+
+ end subroutine get_crust_structure
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/deallocate.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/deallocate.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/deallocate.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/deallocate.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,275 @@
+
+!! DK DK this for the new merged version
+
+ deallocate(xstore_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(ystore_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(zstore_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(xstore_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(ystore_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(zstore_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(xstore_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(ystore_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(zstore_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+!---
+
+ deallocate(xix_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiy_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiz_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etax_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etay_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etaz_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammax_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammay_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammaz_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(xix_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiy_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiz_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etax_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etay_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etaz_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammax_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammay_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammaz_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(xix_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiy_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiz_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etax_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etay_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etaz_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammax_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammay_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammaz_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(rmass_ocean_load,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+!---
+
+ deallocate(displ_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(veloc_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(accel_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(displ_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(veloc_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(accel_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(displ_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(veloc_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(accel_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+!---
+
+ deallocate(R_memory_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(R_memory_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+!---
+
+ deallocate(epsilondev_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(epsilondev_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declar.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/declar.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declar.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declar.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,174 @@
+
+!! DK DK added this temporarily
+!!!!!!!!!!!!! integer, dimension(NSPEC_CRUST_MANTLE) :: perm,invperm
+!! DK DK suppressed for now because useless when CUTHILL-MCKEE is off
+ integer, dimension(1) :: perm,invperm
+
+!! 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(:,:), 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
+
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:,:) :: R_memory_crust_mantle
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:) :: epsilondev_crust_mantle
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:,:) :: R_memory_inner_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:) :: epsilondev_inner_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:) :: rmass_ocean_load
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:) :: &
+ 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), allocatable, dimension(:) :: xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:) :: &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:) :: &
+ 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), allocatable, dimension(:) :: xstore_outer_core,ystore_outer_core,zstore_outer_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:) :: displ_outer_core,veloc_outer_core,accel_outer_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:) :: &
+ 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
+
+ real(kind=CUSTOM_REAL), allocatable, dimension(:) :: xstore_inner_core,ystore_inner_core,zstore_inner_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:) :: displ_inner_core,veloc_inner_core,accel_inner_core
+
+!!!!!!!!!!!!!!!! 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
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_CM) :: &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(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
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_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
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL_CM) :: buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB1D_RADIAL_CM + NGLOB1D_RADIAL_IC) :: &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector
+
+ 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
+
+ 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), 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
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/define_derivation_matrices.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_derivation_matrices.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/define_derivation_matrices.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/define_derivation_matrices.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,178 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 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)
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+! 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
+
+! array with all the weights in the cube
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+! function for calculating derivatives of Lagrange polynomials
+ double precision, external :: lagrange_deriv_GLL
+
+ integer i,j,k,i1,i2,j1,j2,k1,k2
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! 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
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+! calculate derivatives of the Lagrange polynomials
+! and precalculate some products in double precision
+! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
+ do i1=1,NGLLX
+ do i2=1,NGLLX
+ hprime_xx(i2,i1) = sngl(lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX))
+ hprimewgll_xx(i2,i1) = sngl(lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)*wxgll(i2))
+ enddo
+ enddo
+
+ do j1=1,NGLLY
+ do j2=1,NGLLY
+ hprime_yy(j2,j1) = sngl(lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY))
+ hprimewgll_yy(j2,j1) = sngl(lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)*wygll(j2))
+ enddo
+ enddo
+
+ do k1=1,NGLLZ
+ do k2=1,NGLLZ
+ hprime_zz(k2,k1) = sngl(lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ))
+ hprimewgll_zz(k2,k1) = sngl(lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)*wzgll(k2))
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ wgllwgll_xy(i,j) = sngl(wxgll(i)*wygll(j))
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do k=1,NGLLZ
+ wgllwgll_xz(i,k) = sngl(wxgll(i)*wzgll(k))
+ enddo
+ enddo
+
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgllwgll_yz(j,k) = sngl(wygll(j)*wzgll(k))
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
+ enddo
+ enddo
+ enddo
+
+ else ! double precision version
+
+! calculate derivatives of the Lagrange polynomials
+! and precalculate some products in double precision
+! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
+ do i1=1,NGLLX
+ do i2=1,NGLLX
+ hprime_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)
+ hprimewgll_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)*wxgll(i2)
+ enddo
+ enddo
+
+ do j1=1,NGLLY
+ do j2=1,NGLLY
+ hprime_yy(j2,j1) = lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)
+ hprimewgll_yy(j2,j1) = lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)*wygll(j2)
+ enddo
+ enddo
+
+ do k1=1,NGLLZ
+ do k2=1,NGLLZ
+ hprime_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)
+ hprimewgll_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)*wzgll(k2)
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ wgllwgll_xy(i,j) = wxgll(i)*wygll(j)
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do k=1,NGLLZ
+ wgllwgll_xz(i,k) = wxgll(i)*wzgll(k)
+ enddo
+ enddo
+
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgllwgll_yz(j,k) = wygll(j)*wzgll(k)
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ end subroutine define_derivation_matrices
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/define_superbrick.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_superbrick.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/define_superbrick.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/define_superbrick.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,2036 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! define the superbrick that implements the symmetric four-to-two mesh doubling.
+! Generated automatically by a script: UTILS/doubling_brick/define_superbrick.pl
+
+ subroutine define_superbrick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+ logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
+
+ x_superbrick(1) = 3.d0 / 2.d0
+ y_superbrick(1) = 1.d0
+ z_superbrick(1) = 2.d0
+
+ x_superbrick(2) = 3.d0 / 2.d0
+ y_superbrick(2) = 1.d0
+ z_superbrick(2) = 3.d0 / 2.d0
+
+ x_superbrick(3) = 3.d0 / 2.d0
+ y_superbrick(3) = 3.d0 / 2.d0
+ z_superbrick(3) = 3.d0 / 2.d0
+
+ x_superbrick(4) = 3.d0 / 2.d0
+ y_superbrick(4) = 3.d0 / 2.d0
+ z_superbrick(4) = 2.d0
+
+ x_superbrick(5) = 2.d0
+ y_superbrick(5) = 1.d0
+ z_superbrick(5) = 2.d0
+
+ x_superbrick(6) = 2.d0
+ y_superbrick(6) = 1.d0
+ z_superbrick(6) = 1.d0
+
+ x_superbrick(7) = 2.d0
+ y_superbrick(7) = 3.d0 / 2.d0
+ z_superbrick(7) = 1.d0
+
+ x_superbrick(8) = 2.d0
+ y_superbrick(8) = 3.d0 / 2.d0
+ z_superbrick(8) = 2.d0
+
+ x_superbrick(9) = 3.d0 / 2.d0
+ y_superbrick(9) = 2.d0
+ z_superbrick(9) = 1.d0
+
+ x_superbrick(10) = 3.d0 / 2.d0
+ y_superbrick(10) = 2.d0
+ z_superbrick(10) = 2.d0
+
+ x_superbrick(11) = 2.d0
+ y_superbrick(11) = 2.d0
+ z_superbrick(11) = 1.d0 / 2.d0
+
+ x_superbrick(12) = 2.d0
+ y_superbrick(12) = 2.d0
+ z_superbrick(12) = 2.d0
+
+ x_superbrick(13) = 1.d0
+ y_superbrick(13) = 1.d0
+ z_superbrick(13) = 1.d0
+
+ x_superbrick(14) = 1.d0
+ y_superbrick(14) = 1.d0
+ z_superbrick(14) = 1.d0 / 2.d0
+
+ x_superbrick(15) = 1.d0
+ y_superbrick(15) = 2.d0
+ z_superbrick(15) = 1.d0 / 2.d0
+
+ x_superbrick(16) = 1.d0
+ y_superbrick(16) = 2.d0
+ z_superbrick(16) = 1.d0
+
+ x_superbrick(17) = 3.d0 / 2.d0
+ y_superbrick(17) = 1.d0
+ z_superbrick(17) = 1.d0
+
+ x_superbrick(18) = 2.d0
+ y_superbrick(18) = 1.d0
+ z_superbrick(18) = 1.d0 / 2.d0
+
+ x_superbrick(19) = 1.d0
+ y_superbrick(19) = 1.d0
+ z_superbrick(19) = 3.d0 / 2.d0
+
+ x_superbrick(20) = 1.d0
+ y_superbrick(20) = 1.d0
+ z_superbrick(20) = 2.d0
+
+ x_superbrick(21) = 1.d0
+ y_superbrick(21) = 3.d0 / 2.d0
+ z_superbrick(21) = 3.d0 / 2.d0
+
+ x_superbrick(22) = 1.d0
+ y_superbrick(22) = 3.d0 / 2.d0
+ z_superbrick(22) = 2.d0
+
+ x_superbrick(23) = 1.d0
+ y_superbrick(23) = 2.d0
+ z_superbrick(23) = 2.d0
+
+ x_superbrick(24) = 1.d0
+ y_superbrick(24) = 1.d0
+ z_superbrick(24) = 0.d0
+
+ x_superbrick(25) = 2.d0
+ y_superbrick(25) = 1.d0
+ z_superbrick(25) = 0.d0
+
+ x_superbrick(26) = 2.d0
+ y_superbrick(26) = 2.d0
+ z_superbrick(26) = 0.d0
+
+ x_superbrick(27) = 1.d0
+ y_superbrick(27) = 2.d0
+ z_superbrick(27) = 0.d0
+
+ x_superbrick(28) = 3.d0 / 2.d0
+ y_superbrick(28) = 1.d0 / 2.d0
+ z_superbrick(28) = 3.d0 / 2.d0
+
+ x_superbrick(29) = 3.d0 / 2.d0
+ y_superbrick(29) = 1.d0 / 2.d0
+ z_superbrick(29) = 2.d0
+
+ x_superbrick(30) = 2.d0
+ y_superbrick(30) = 1.d0 / 2.d0
+ z_superbrick(30) = 1.d0
+
+ x_superbrick(31) = 2.d0
+ y_superbrick(31) = 1.d0 / 2.d0
+ z_superbrick(31) = 2.d0
+
+ x_superbrick(32) = 3.d0 / 2.d0
+ y_superbrick(32) = 0.d0
+ z_superbrick(32) = 1.d0
+
+ x_superbrick(33) = 3.d0 / 2.d0
+ y_superbrick(33) = 0.d0
+ z_superbrick(33) = 2.d0
+
+ x_superbrick(34) = 2.d0
+ y_superbrick(34) = 0.d0
+ z_superbrick(34) = 1.d0 / 2.d0
+
+ x_superbrick(35) = 2.d0
+ y_superbrick(35) = 0.d0
+ z_superbrick(35) = 2.d0
+
+ x_superbrick(36) = 1.d0
+ y_superbrick(36) = 0.d0
+ z_superbrick(36) = 1.d0 / 2.d0
+
+ x_superbrick(37) = 1.d0
+ y_superbrick(37) = 0.d0
+ z_superbrick(37) = 1.d0
+
+ x_superbrick(38) = 1.d0
+ y_superbrick(38) = 1.d0 / 2.d0
+ z_superbrick(38) = 3.d0 / 2.d0
+
+ x_superbrick(39) = 1.d0
+ y_superbrick(39) = 1.d0 / 2.d0
+ z_superbrick(39) = 2.d0
+
+ x_superbrick(40) = 1.d0
+ y_superbrick(40) = 0.d0
+ z_superbrick(40) = 2.d0
+
+ x_superbrick(41) = 2.d0
+ y_superbrick(41) = 0.d0
+ z_superbrick(41) = 0.d0
+
+ x_superbrick(42) = 1.d0
+ y_superbrick(42) = 0.d0
+ z_superbrick(42) = 0.d0
+
+ x_superbrick(43) = 1.d0 / 2.d0
+ y_superbrick(43) = 1.d0
+ z_superbrick(43) = 2.d0
+
+ x_superbrick(44) = 1.d0 / 2.d0
+ y_superbrick(44) = 1.d0
+ z_superbrick(44) = 3.d0 / 2.d0
+
+ x_superbrick(45) = 1.d0 / 2.d0
+ y_superbrick(45) = 3.d0 / 2.d0
+ z_superbrick(45) = 3.d0 / 2.d0
+
+ x_superbrick(46) = 1.d0 / 2.d0
+ y_superbrick(46) = 3.d0 / 2.d0
+ z_superbrick(46) = 2.d0
+
+ x_superbrick(47) = 0.d0
+ y_superbrick(47) = 1.d0
+ z_superbrick(47) = 2.d0
+
+ x_superbrick(48) = 0.d0
+ y_superbrick(48) = 1.d0
+ z_superbrick(48) = 1.d0
+
+ x_superbrick(49) = 0.d0
+ y_superbrick(49) = 3.d0 / 2.d0
+ z_superbrick(49) = 1.d0
+
+ x_superbrick(50) = 0.d0
+ y_superbrick(50) = 3.d0 / 2.d0
+ z_superbrick(50) = 2.d0
+
+ x_superbrick(51) = 1.d0 / 2.d0
+ y_superbrick(51) = 2.d0
+ z_superbrick(51) = 1.d0
+
+ x_superbrick(52) = 1.d0 / 2.d0
+ y_superbrick(52) = 2.d0
+ z_superbrick(52) = 2.d0
+
+ x_superbrick(53) = 0.d0
+ y_superbrick(53) = 2.d0
+ z_superbrick(53) = 1.d0 / 2.d0
+
+ x_superbrick(54) = 0.d0
+ y_superbrick(54) = 2.d0
+ z_superbrick(54) = 2.d0
+
+ x_superbrick(55) = 1.d0 / 2.d0
+ y_superbrick(55) = 1.d0
+ z_superbrick(55) = 1.d0
+
+ x_superbrick(56) = 0.d0
+ y_superbrick(56) = 1.d0
+ z_superbrick(56) = 1.d0 / 2.d0
+
+ x_superbrick(57) = 0.d0
+ y_superbrick(57) = 1.d0
+ z_superbrick(57) = 0.d0
+
+ x_superbrick(58) = 0.d0
+ y_superbrick(58) = 2.d0
+ z_superbrick(58) = 0.d0
+
+ x_superbrick(59) = 1.d0 / 2.d0
+ y_superbrick(59) = 1.d0 / 2.d0
+ z_superbrick(59) = 3.d0 / 2.d0
+
+ x_superbrick(60) = 1.d0 / 2.d0
+ y_superbrick(60) = 1.d0 / 2.d0
+ z_superbrick(60) = 2.d0
+
+ x_superbrick(61) = 0.d0
+ y_superbrick(61) = 1.d0 / 2.d0
+ z_superbrick(61) = 1.d0
+
+ x_superbrick(62) = 0.d0
+ y_superbrick(62) = 1.d0 / 2.d0
+ z_superbrick(62) = 2.d0
+
+ x_superbrick(63) = 1.d0 / 2.d0
+ y_superbrick(63) = 0.d0
+ z_superbrick(63) = 1.d0
+
+ x_superbrick(64) = 1.d0 / 2.d0
+ y_superbrick(64) = 0.d0
+ z_superbrick(64) = 2.d0
+
+ x_superbrick(65) = 0.d0
+ y_superbrick(65) = 0.d0
+ z_superbrick(65) = 1.d0 / 2.d0
+
+ x_superbrick(66) = 0.d0
+ y_superbrick(66) = 0.d0
+ z_superbrick(66) = 2.d0
+
+ x_superbrick(67) = 0.d0
+ y_superbrick(67) = 0.d0
+ z_superbrick(67) = 0.d0
+
+ ibool_superbrick(1, 1) = 2
+ ibool_superbrick(2, 1) = 6
+ ibool_superbrick(3, 1) = 7
+ ibool_superbrick(4, 1) = 3
+ ibool_superbrick(5, 1) = 1
+ ibool_superbrick(6, 1) = 5
+ ibool_superbrick(7, 1) = 8
+ ibool_superbrick(8, 1) = 4
+
+ ibool_superbrick(1, 2) = 3
+ ibool_superbrick(2, 2) = 7
+ ibool_superbrick(3, 2) = 11
+ ibool_superbrick(4, 2) = 9
+ ibool_superbrick(5, 2) = 4
+ ibool_superbrick(6, 2) = 8
+ ibool_superbrick(7, 2) = 12
+ ibool_superbrick(8, 2) = 10
+
+ ibool_superbrick(1, 3) = 14
+ ibool_superbrick(2, 3) = 18
+ ibool_superbrick(3, 3) = 11
+ ibool_superbrick(4, 3) = 15
+ ibool_superbrick(5, 3) = 13
+ ibool_superbrick(6, 3) = 17
+ ibool_superbrick(7, 3) = 9
+ ibool_superbrick(8, 3) = 16
+
+ ibool_superbrick(1, 4) = 19
+ ibool_superbrick(2, 4) = 2
+ ibool_superbrick(3, 4) = 3
+ ibool_superbrick(4, 4) = 21
+ ibool_superbrick(5, 4) = 20
+ ibool_superbrick(6, 4) = 1
+ ibool_superbrick(7, 4) = 4
+ ibool_superbrick(8, 4) = 22
+
+ ibool_superbrick(1, 5) = 17
+ ibool_superbrick(2, 5) = 18
+ ibool_superbrick(3, 5) = 11
+ ibool_superbrick(4, 5) = 9
+ ibool_superbrick(5, 5) = 2
+ ibool_superbrick(6, 5) = 6
+ ibool_superbrick(7, 5) = 7
+ ibool_superbrick(8, 5) = 3
+
+ ibool_superbrick(1, 6) = 21
+ ibool_superbrick(2, 6) = 3
+ ibool_superbrick(3, 6) = 9
+ ibool_superbrick(4, 6) = 16
+ ibool_superbrick(5, 6) = 22
+ ibool_superbrick(6, 6) = 4
+ ibool_superbrick(7, 6) = 10
+ ibool_superbrick(8, 6) = 23
+
+ ibool_superbrick(1, 7) = 13
+ ibool_superbrick(2, 7) = 17
+ ibool_superbrick(3, 7) = 9
+ ibool_superbrick(4, 7) = 16
+ ibool_superbrick(5, 7) = 19
+ ibool_superbrick(6, 7) = 2
+ ibool_superbrick(7, 7) = 3
+ ibool_superbrick(8, 7) = 21
+
+ ibool_superbrick(1, 8) = 24
+ ibool_superbrick(2, 8) = 25
+ ibool_superbrick(3, 8) = 26
+ ibool_superbrick(4, 8) = 27
+ ibool_superbrick(5, 8) = 14
+ ibool_superbrick(6, 8) = 18
+ ibool_superbrick(7, 8) = 11
+ ibool_superbrick(8, 8) = 15
+
+ ibool_superbrick(1, 9) = 28
+ ibool_superbrick(2, 9) = 30
+ ibool_superbrick(3, 9) = 6
+ ibool_superbrick(4, 9) = 2
+ ibool_superbrick(5, 9) = 29
+ ibool_superbrick(6, 9) = 31
+ ibool_superbrick(7, 9) = 5
+ ibool_superbrick(8, 9) = 1
+
+ ibool_superbrick(1, 10) = 32
+ ibool_superbrick(2, 10) = 34
+ ibool_superbrick(3, 10) = 30
+ ibool_superbrick(4, 10) = 28
+ ibool_superbrick(5, 10) = 33
+ ibool_superbrick(6, 10) = 35
+ ibool_superbrick(7, 10) = 31
+ ibool_superbrick(8, 10) = 29
+
+ ibool_superbrick(1, 11) = 36
+ ibool_superbrick(2, 11) = 34
+ ibool_superbrick(3, 11) = 18
+ ibool_superbrick(4, 11) = 14
+ ibool_superbrick(5, 11) = 37
+ ibool_superbrick(6, 11) = 32
+ ibool_superbrick(7, 11) = 17
+ ibool_superbrick(8, 11) = 13
+
+ ibool_superbrick(1, 12) = 38
+ ibool_superbrick(2, 12) = 28
+ ibool_superbrick(3, 12) = 2
+ ibool_superbrick(4, 12) = 19
+ ibool_superbrick(5, 12) = 39
+ ibool_superbrick(6, 12) = 29
+ ibool_superbrick(7, 12) = 1
+ ibool_superbrick(8, 12) = 20
+
+ ibool_superbrick(1, 13) = 32
+ ibool_superbrick(2, 13) = 34
+ ibool_superbrick(3, 13) = 18
+ ibool_superbrick(4, 13) = 17
+ ibool_superbrick(5, 13) = 28
+ ibool_superbrick(6, 13) = 30
+ ibool_superbrick(7, 13) = 6
+ ibool_superbrick(8, 13) = 2
+
+ ibool_superbrick(1, 14) = 37
+ ibool_superbrick(2, 14) = 32
+ ibool_superbrick(3, 14) = 28
+ ibool_superbrick(4, 14) = 38
+ ibool_superbrick(5, 14) = 40
+ ibool_superbrick(6, 14) = 33
+ ibool_superbrick(7, 14) = 29
+ ibool_superbrick(8, 14) = 39
+
+ ibool_superbrick(1, 15) = 37
+ ibool_superbrick(2, 15) = 32
+ ibool_superbrick(3, 15) = 17
+ ibool_superbrick(4, 15) = 13
+ ibool_superbrick(5, 15) = 38
+ ibool_superbrick(6, 15) = 28
+ ibool_superbrick(7, 15) = 2
+ ibool_superbrick(8, 15) = 19
+
+ ibool_superbrick(1, 16) = 42
+ ibool_superbrick(2, 16) = 41
+ ibool_superbrick(3, 16) = 25
+ ibool_superbrick(4, 16) = 24
+ ibool_superbrick(5, 16) = 36
+ ibool_superbrick(6, 16) = 34
+ ibool_superbrick(7, 16) = 18
+ ibool_superbrick(8, 16) = 14
+
+ ibool_superbrick(1, 17) = 48
+ ibool_superbrick(2, 17) = 44
+ ibool_superbrick(3, 17) = 45
+ ibool_superbrick(4, 17) = 49
+ ibool_superbrick(5, 17) = 47
+ ibool_superbrick(6, 17) = 43
+ ibool_superbrick(7, 17) = 46
+ ibool_superbrick(8, 17) = 50
+
+ ibool_superbrick(1, 18) = 49
+ ibool_superbrick(2, 18) = 45
+ ibool_superbrick(3, 18) = 51
+ ibool_superbrick(4, 18) = 53
+ ibool_superbrick(5, 18) = 50
+ ibool_superbrick(6, 18) = 46
+ ibool_superbrick(7, 18) = 52
+ ibool_superbrick(8, 18) = 54
+
+ ibool_superbrick(1, 19) = 56
+ ibool_superbrick(2, 19) = 14
+ ibool_superbrick(3, 19) = 15
+ ibool_superbrick(4, 19) = 53
+ ibool_superbrick(5, 19) = 55
+ ibool_superbrick(6, 19) = 13
+ ibool_superbrick(7, 19) = 16
+ ibool_superbrick(8, 19) = 51
+
+ ibool_superbrick(1, 20) = 44
+ ibool_superbrick(2, 20) = 19
+ ibool_superbrick(3, 20) = 21
+ ibool_superbrick(4, 20) = 45
+ ibool_superbrick(5, 20) = 43
+ ibool_superbrick(6, 20) = 20
+ ibool_superbrick(7, 20) = 22
+ ibool_superbrick(8, 20) = 46
+
+ ibool_superbrick(1, 21) = 56
+ ibool_superbrick(2, 21) = 55
+ ibool_superbrick(3, 21) = 51
+ ibool_superbrick(4, 21) = 53
+ ibool_superbrick(5, 21) = 48
+ ibool_superbrick(6, 21) = 44
+ ibool_superbrick(7, 21) = 45
+ ibool_superbrick(8, 21) = 49
+
+ ibool_superbrick(1, 22) = 45
+ ibool_superbrick(2, 22) = 21
+ ibool_superbrick(3, 22) = 16
+ ibool_superbrick(4, 22) = 51
+ ibool_superbrick(5, 22) = 46
+ ibool_superbrick(6, 22) = 22
+ ibool_superbrick(7, 22) = 23
+ ibool_superbrick(8, 22) = 52
+
+ ibool_superbrick(1, 23) = 55
+ ibool_superbrick(2, 23) = 13
+ ibool_superbrick(3, 23) = 16
+ ibool_superbrick(4, 23) = 51
+ ibool_superbrick(5, 23) = 44
+ ibool_superbrick(6, 23) = 19
+ ibool_superbrick(7, 23) = 21
+ ibool_superbrick(8, 23) = 45
+
+ ibool_superbrick(1, 24) = 57
+ ibool_superbrick(2, 24) = 24
+ ibool_superbrick(3, 24) = 27
+ ibool_superbrick(4, 24) = 58
+ ibool_superbrick(5, 24) = 56
+ ibool_superbrick(6, 24) = 14
+ ibool_superbrick(7, 24) = 15
+ ibool_superbrick(8, 24) = 53
+
+ ibool_superbrick(1, 25) = 61
+ ibool_superbrick(2, 25) = 59
+ ibool_superbrick(3, 25) = 44
+ ibool_superbrick(4, 25) = 48
+ ibool_superbrick(5, 25) = 62
+ ibool_superbrick(6, 25) = 60
+ ibool_superbrick(7, 25) = 43
+ ibool_superbrick(8, 25) = 47
+
+ ibool_superbrick(1, 26) = 65
+ ibool_superbrick(2, 26) = 63
+ ibool_superbrick(3, 26) = 59
+ ibool_superbrick(4, 26) = 61
+ ibool_superbrick(5, 26) = 66
+ ibool_superbrick(6, 26) = 64
+ ibool_superbrick(7, 26) = 60
+ ibool_superbrick(8, 26) = 62
+
+ ibool_superbrick(1, 27) = 65
+ ibool_superbrick(2, 27) = 36
+ ibool_superbrick(3, 27) = 14
+ ibool_superbrick(4, 27) = 56
+ ibool_superbrick(5, 27) = 63
+ ibool_superbrick(6, 27) = 37
+ ibool_superbrick(7, 27) = 13
+ ibool_superbrick(8, 27) = 55
+
+ ibool_superbrick(1, 28) = 59
+ ibool_superbrick(2, 28) = 38
+ ibool_superbrick(3, 28) = 19
+ ibool_superbrick(4, 28) = 44
+ ibool_superbrick(5, 28) = 60
+ ibool_superbrick(6, 28) = 39
+ ibool_superbrick(7, 28) = 20
+ ibool_superbrick(8, 28) = 43
+
+ ibool_superbrick(1, 29) = 65
+ ibool_superbrick(2, 29) = 63
+ ibool_superbrick(3, 29) = 55
+ ibool_superbrick(4, 29) = 56
+ ibool_superbrick(5, 29) = 61
+ ibool_superbrick(6, 29) = 59
+ ibool_superbrick(7, 29) = 44
+ ibool_superbrick(8, 29) = 48
+
+ ibool_superbrick(1, 30) = 63
+ ibool_superbrick(2, 30) = 37
+ ibool_superbrick(3, 30) = 38
+ ibool_superbrick(4, 30) = 59
+ ibool_superbrick(5, 30) = 64
+ ibool_superbrick(6, 30) = 40
+ ibool_superbrick(7, 30) = 39
+ ibool_superbrick(8, 30) = 60
+
+ ibool_superbrick(1, 31) = 63
+ ibool_superbrick(2, 31) = 37
+ ibool_superbrick(3, 31) = 13
+ ibool_superbrick(4, 31) = 55
+ ibool_superbrick(5, 31) = 59
+ ibool_superbrick(6, 31) = 38
+ ibool_superbrick(7, 31) = 19
+ ibool_superbrick(8, 31) = 44
+
+ ibool_superbrick(1, 32) = 67
+ ibool_superbrick(2, 32) = 42
+ ibool_superbrick(3, 32) = 24
+ ibool_superbrick(4, 32) = 57
+ ibool_superbrick(5, 32) = 65
+ ibool_superbrick(6, 32) = 36
+ ibool_superbrick(7, 32) = 14
+ ibool_superbrick(8, 32) = 56
+
+
+ iboun_sb(:,:) = .false.
+
+ iboun_sb(1,2) = .true.
+ iboun_sb(1,6) = .true.
+ iboun_sb(2,2) = .true.
+ iboun_sb(2,4) = .true.
+ iboun_sb(2,6) = .true.
+ iboun_sb(3,4) = .true.
+ iboun_sb(4,6) = .true.
+ iboun_sb(5,2) = .true.
+ iboun_sb(6,4) = .true.
+ iboun_sb(6,6) = .true.
+ iboun_sb(8,2) = .true.
+ iboun_sb(8,4) = .true.
+ iboun_sb(8,5) = .true.
+ iboun_sb(9,2) = .true.
+ iboun_sb(9,6) = .true.
+ iboun_sb(10,2) = .true.
+ iboun_sb(10,3) = .true.
+ iboun_sb(10,6) = .true.
+ iboun_sb(11,3) = .true.
+ iboun_sb(12,6) = .true.
+ iboun_sb(13,2) = .true.
+ iboun_sb(14,3) = .true.
+ iboun_sb(14,6) = .true.
+ iboun_sb(16,2) = .true.
+ iboun_sb(16,3) = .true.
+ iboun_sb(16,5) = .true.
+ iboun_sb(17,1) = .true.
+ iboun_sb(17,6) = .true.
+ iboun_sb(18,1) = .true.
+ iboun_sb(18,4) = .true.
+ iboun_sb(18,6) = .true.
+ iboun_sb(19,4) = .true.
+ iboun_sb(20,6) = .true.
+ iboun_sb(21,1) = .true.
+ iboun_sb(22,4) = .true.
+ iboun_sb(22,6) = .true.
+ iboun_sb(24,1) = .true.
+ iboun_sb(24,4) = .true.
+ iboun_sb(24,5) = .true.
+ iboun_sb(25,1) = .true.
+ iboun_sb(25,6) = .true.
+ iboun_sb(26,1) = .true.
+ iboun_sb(26,3) = .true.
+ iboun_sb(26,6) = .true.
+ iboun_sb(27,3) = .true.
+ iboun_sb(28,6) = .true.
+ iboun_sb(29,1) = .true.
+ iboun_sb(30,3) = .true.
+ iboun_sb(30,6) = .true.
+ iboun_sb(32,1) = .true.
+ iboun_sb(32,3) = .true.
+ iboun_sb(32,5) = .true.
+
+ end subroutine define_superbrick
+
+
+ subroutine define_superbrick_one_layer(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+ logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
+
+x_superbrick(1) = 3.d0 / 2.d0
+y_superbrick(1) = 1.d0
+z_superbrick(1) = 1.d0
+
+x_superbrick(2) = 3.d0 / 2.d0
+y_superbrick(2) = 1.d0
+z_superbrick(2) = 2.d0 / 3.d0
+
+x_superbrick(3) = 3.d0 / 2.d0
+y_superbrick(3) = 3.d0 / 2.d0
+z_superbrick(3) = 2.d0 / 3.d0
+
+x_superbrick(4) = 3.d0 / 2.d0
+y_superbrick(4) = 3.d0 / 2.d0
+z_superbrick(4) = 1.d0
+
+x_superbrick(5) = 2.d0
+y_superbrick(5) = 1.d0
+z_superbrick(5) = 1.d0
+
+x_superbrick(6) = 2.d0
+y_superbrick(6) = 1.d0
+z_superbrick(6) = 1.d0 / 3.d0
+
+x_superbrick(7) = 2.d0
+y_superbrick(7) = 3.d0 / 2.d0
+z_superbrick(7) = 1.d0 / 3.d0
+
+x_superbrick(8) = 2.d0
+y_superbrick(8) = 3.d0 / 2.d0
+z_superbrick(8) = 1.d0
+
+x_superbrick(9) = 3.d0 / 2.d0
+y_superbrick(9) = 2.d0
+z_superbrick(9) = 1.d0 / 3.d0
+
+x_superbrick(10) = 3.d0 / 2.d0
+y_superbrick(10) = 2.d0
+z_superbrick(10) = 1.d0
+
+x_superbrick(11) = 2.d0
+y_superbrick(11) = 2.d0
+z_superbrick(11) = 0.d0
+
+x_superbrick(12) = 2.d0
+y_superbrick(12) = 2.d0
+z_superbrick(12) = 1.d0
+
+x_superbrick(13) = 1.d0
+y_superbrick(13) = 1.d0
+z_superbrick(13) = 1.d0 / 3.d0
+
+x_superbrick(14) = 1.d0
+y_superbrick(14) = 1.d0
+z_superbrick(14) = 0.d0
+
+x_superbrick(15) = 1.d0
+y_superbrick(15) = 2.d0
+z_superbrick(15) = 0.d0
+
+x_superbrick(16) = 1.d0
+y_superbrick(16) = 2.d0
+z_superbrick(16) = 1.d0 / 3.d0
+
+x_superbrick(17) = 3.d0 / 2.d0
+y_superbrick(17) = 1.d0
+z_superbrick(17) = 1.d0 / 3.d0
+
+x_superbrick(18) = 2.d0
+y_superbrick(18) = 1.d0
+z_superbrick(18) = 0.d0
+
+x_superbrick(19) = 1.d0
+y_superbrick(19) = 1.d0
+z_superbrick(19) = 2.d0 / 3.d0
+
+x_superbrick(20) = 1.d0
+y_superbrick(20) = 1.d0
+z_superbrick(20) = 1.d0
+
+x_superbrick(21) = 1.d0
+y_superbrick(21) = 3.d0 / 2.d0
+z_superbrick(21) = 2.d0 / 3.d0
+
+x_superbrick(22) = 1.d0
+y_superbrick(22) = 3.d0 / 2.d0
+z_superbrick(22) = 1.d0
+
+x_superbrick(23) = 1.d0
+y_superbrick(23) = 2.d0
+z_superbrick(23) = 1.d0
+
+x_superbrick(24) = 3.d0 / 2.d0
+y_superbrick(24) = 1.d0 / 2.d0
+z_superbrick(24) = 2.d0 / 3.d0
+
+x_superbrick(25) = 3.d0 / 2.d0
+y_superbrick(25) = 1.d0 / 2.d0
+z_superbrick(25) = 1.d0
+
+x_superbrick(26) = 2.d0
+y_superbrick(26) = 1.d0 / 2.d0
+z_superbrick(26) = 1.d0 / 3.d0
+
+x_superbrick(27) = 2.d0
+y_superbrick(27) = 1.d0 / 2.d0
+z_superbrick(27) = 1.d0
+
+x_superbrick(28) = 3.d0 / 2.d0
+y_superbrick(28) = 0.d0
+z_superbrick(28) = 1.d0 / 3.d0
+
+x_superbrick(29) = 3.d0 / 2.d0
+y_superbrick(29) = 0.d0
+z_superbrick(29) = 1.d0
+
+x_superbrick(30) = 2.d0
+y_superbrick(30) = 0.d0
+z_superbrick(30) = 0.d0
+
+x_superbrick(31) = 2.d0
+y_superbrick(31) = 0.d0
+z_superbrick(31) = 1.d0
+
+x_superbrick(32) = 1.d0
+y_superbrick(32) = 0.d0
+z_superbrick(32) = 0.d0
+
+x_superbrick(33) = 1.d0
+y_superbrick(33) = 0.d0
+z_superbrick(33) = 1.d0 / 3.d0
+
+x_superbrick(34) = 1.d0
+y_superbrick(34) = 1.d0 / 2.d0
+z_superbrick(34) = 2.d0 / 3.d0
+
+x_superbrick(35) = 1.d0
+y_superbrick(35) = 1.d0 / 2.d0
+z_superbrick(35) = 1.d0
+
+x_superbrick(36) = 1.d0
+y_superbrick(36) = 0.d0
+z_superbrick(36) = 1.d0
+
+x_superbrick(37) = 1.d0 / 2.d0
+y_superbrick(37) = 1.d0
+z_superbrick(37) = 1.d0
+
+x_superbrick(38) = 1.d0 / 2.d0
+y_superbrick(38) = 1.d0
+z_superbrick(38) = 2.d0 / 3.d0
+
+x_superbrick(39) = 1.d0 / 2.d0
+y_superbrick(39) = 3.d0 / 2.d0
+z_superbrick(39) = 2.d0 / 3.d0
+
+x_superbrick(40) = 1.d0 / 2.d0
+y_superbrick(40) = 3.d0 / 2.d0
+z_superbrick(40) = 1.d0
+
+x_superbrick(41) = 0.d0
+y_superbrick(41) = 1.d0
+z_superbrick(41) = 1.d0
+
+x_superbrick(42) = 0.d0
+y_superbrick(42) = 1.d0
+z_superbrick(42) = 1.d0 / 3.d0
+
+x_superbrick(43) = 0.d0
+y_superbrick(43) = 3.d0 / 2.d0
+z_superbrick(43) = 1.d0 / 3.d0
+
+x_superbrick(44) = 0.d0
+y_superbrick(44) = 3.d0 / 2.d0
+z_superbrick(44) = 1.d0
+
+x_superbrick(45) = 1.d0 / 2.d0
+y_superbrick(45) = 2.d0
+z_superbrick(45) = 1.d0 / 3.d0
+
+x_superbrick(46) = 1.d0 / 2.d0
+y_superbrick(46) = 2.d0
+z_superbrick(46) = 1.d0
+
+x_superbrick(47) = 0.d0
+y_superbrick(47) = 2.d0
+z_superbrick(47) = 0.d0
+
+x_superbrick(48) = 0.d0
+y_superbrick(48) = 2.d0
+z_superbrick(48) = 1.d0
+
+x_superbrick(49) = 1.d0 / 2.d0
+y_superbrick(49) = 1.d0
+z_superbrick(49) = 1.d0 / 3.d0
+
+x_superbrick(50) = 0.d0
+y_superbrick(50) = 1.d0
+z_superbrick(50) = 0.d0
+
+x_superbrick(51) = 1.d0 / 2.d0
+y_superbrick(51) = 1.d0 / 2.d0
+z_superbrick(51) = 2.d0 / 3.d0
+
+x_superbrick(52) = 1.d0 / 2.d0
+y_superbrick(52) = 1.d0 / 2.d0
+z_superbrick(52) = 1.d0
+
+x_superbrick(53) = 0.d0
+y_superbrick(53) = 1.d0 / 2.d0
+z_superbrick(53) = 1.d0 / 3.d0
+
+x_superbrick(54) = 0.d0
+y_superbrick(54) = 1.d0 / 2.d0
+z_superbrick(54) = 1.d0
+
+x_superbrick(55) = 1.d0 / 2.d0
+y_superbrick(55) = 0.d0
+z_superbrick(55) = 1.d0 / 3.d0
+
+x_superbrick(56) = 1.d0 / 2.d0
+y_superbrick(56) = 0.d0
+z_superbrick(56) = 1.d0
+
+x_superbrick(57) = 0.d0
+y_superbrick(57) = 0.d0
+z_superbrick(57) = 0.d0
+
+x_superbrick(58) = 0.d0
+y_superbrick(58) = 0.d0
+z_superbrick(58) = 1.d0
+
+ibool_superbrick(1, 1) = 2
+ibool_superbrick(2, 1) = 6
+ibool_superbrick(3, 1) = 7
+ibool_superbrick(4, 1) = 3
+ibool_superbrick(5, 1) = 1
+ibool_superbrick(6, 1) = 5
+ibool_superbrick(7, 1) = 8
+ibool_superbrick(8, 1) = 4
+
+ibool_superbrick(1, 2) = 3
+ibool_superbrick(2, 2) = 7
+ibool_superbrick(3, 2) = 11
+ibool_superbrick(4, 2) = 9
+ibool_superbrick(5, 2) = 4
+ibool_superbrick(6, 2) = 8
+ibool_superbrick(7, 2) = 12
+ibool_superbrick(8, 2) = 10
+
+ibool_superbrick(1, 3) = 14
+ibool_superbrick(2, 3) = 18
+ibool_superbrick(3, 3) = 11
+ibool_superbrick(4, 3) = 15
+ibool_superbrick(5, 3) = 13
+ibool_superbrick(6, 3) = 17
+ibool_superbrick(7, 3) = 9
+ibool_superbrick(8, 3) = 16
+
+ibool_superbrick(1, 4) = 19
+ibool_superbrick(2, 4) = 2
+ibool_superbrick(3, 4) = 3
+ibool_superbrick(4, 4) = 21
+ibool_superbrick(5, 4) = 20
+ibool_superbrick(6, 4) = 1
+ibool_superbrick(7, 4) = 4
+ibool_superbrick(8, 4) = 22
+
+ibool_superbrick(1, 5) = 17
+ibool_superbrick(2, 5) = 18
+ibool_superbrick(3, 5) = 11
+ibool_superbrick(4, 5) = 9
+ibool_superbrick(5, 5) = 2
+ibool_superbrick(6, 5) = 6
+ibool_superbrick(7, 5) = 7
+ibool_superbrick(8, 5) = 3
+
+ibool_superbrick(1, 6) = 21
+ibool_superbrick(2, 6) = 3
+ibool_superbrick(3, 6) = 9
+ibool_superbrick(4, 6) = 16
+ibool_superbrick(5, 6) = 22
+ibool_superbrick(6, 6) = 4
+ibool_superbrick(7, 6) = 10
+ibool_superbrick(8, 6) = 23
+
+ibool_superbrick(1, 7) = 13
+ibool_superbrick(2, 7) = 17
+ibool_superbrick(3, 7) = 9
+ibool_superbrick(4, 7) = 16
+ibool_superbrick(5, 7) = 19
+ibool_superbrick(6, 7) = 2
+ibool_superbrick(7, 7) = 3
+ibool_superbrick(8, 7) = 21
+
+ibool_superbrick(1, 8) = 24
+ibool_superbrick(2, 8) = 26
+ibool_superbrick(3, 8) = 6
+ibool_superbrick(4, 8) = 2
+ibool_superbrick(5, 8) = 25
+ibool_superbrick(6, 8) = 27
+ibool_superbrick(7, 8) = 5
+ibool_superbrick(8, 8) = 1
+
+ibool_superbrick(1, 9) = 28
+ibool_superbrick(2, 9) = 30
+ibool_superbrick(3, 9) = 26
+ibool_superbrick(4, 9) = 24
+ibool_superbrick(5, 9) = 29
+ibool_superbrick(6, 9) = 31
+ibool_superbrick(7, 9) = 27
+ibool_superbrick(8, 9) = 25
+
+ibool_superbrick(1, 10) = 32
+ibool_superbrick(2, 10) = 30
+ibool_superbrick(3, 10) = 18
+ibool_superbrick(4, 10) = 14
+ibool_superbrick(5, 10) = 33
+ibool_superbrick(6, 10) = 28
+ibool_superbrick(7, 10) = 17
+ibool_superbrick(8, 10) = 13
+
+ibool_superbrick(1, 11) = 34
+ibool_superbrick(2, 11) = 24
+ibool_superbrick(3, 11) = 2
+ibool_superbrick(4, 11) = 19
+ibool_superbrick(5, 11) = 35
+ibool_superbrick(6, 11) = 25
+ibool_superbrick(7, 11) = 1
+ibool_superbrick(8, 11) = 20
+
+ibool_superbrick(1, 12) = 28
+ibool_superbrick(2, 12) = 30
+ibool_superbrick(3, 12) = 18
+ibool_superbrick(4, 12) = 17
+ibool_superbrick(5, 12) = 24
+ibool_superbrick(6, 12) = 26
+ibool_superbrick(7, 12) = 6
+ibool_superbrick(8, 12) = 2
+
+ibool_superbrick(1, 13) = 33
+ibool_superbrick(2, 13) = 28
+ibool_superbrick(3, 13) = 24
+ibool_superbrick(4, 13) = 34
+ibool_superbrick(5, 13) = 36
+ibool_superbrick(6, 13) = 29
+ibool_superbrick(7, 13) = 25
+ibool_superbrick(8, 13) = 35
+
+ibool_superbrick(1, 14) = 33
+ibool_superbrick(2, 14) = 28
+ibool_superbrick(3, 14) = 17
+ibool_superbrick(4, 14) = 13
+ibool_superbrick(5, 14) = 34
+ibool_superbrick(6, 14) = 24
+ibool_superbrick(7, 14) = 2
+ibool_superbrick(8, 14) = 19
+
+ibool_superbrick(1, 15) = 42
+ibool_superbrick(2, 15) = 38
+ibool_superbrick(3, 15) = 39
+ibool_superbrick(4, 15) = 43
+ibool_superbrick(5, 15) = 41
+ibool_superbrick(6, 15) = 37
+ibool_superbrick(7, 15) = 40
+ibool_superbrick(8, 15) = 44
+
+ibool_superbrick(1, 16) = 43
+ibool_superbrick(2, 16) = 39
+ibool_superbrick(3, 16) = 45
+ibool_superbrick(4, 16) = 47
+ibool_superbrick(5, 16) = 44
+ibool_superbrick(6, 16) = 40
+ibool_superbrick(7, 16) = 46
+ibool_superbrick(8, 16) = 48
+
+ibool_superbrick(1, 17) = 50
+ibool_superbrick(2, 17) = 14
+ibool_superbrick(3, 17) = 15
+ibool_superbrick(4, 17) = 47
+ibool_superbrick(5, 17) = 49
+ibool_superbrick(6, 17) = 13
+ibool_superbrick(7, 17) = 16
+ibool_superbrick(8, 17) = 45
+
+ibool_superbrick(1, 18) = 38
+ibool_superbrick(2, 18) = 19
+ibool_superbrick(3, 18) = 21
+ibool_superbrick(4, 18) = 39
+ibool_superbrick(5, 18) = 37
+ibool_superbrick(6, 18) = 20
+ibool_superbrick(7, 18) = 22
+ibool_superbrick(8, 18) = 40
+
+ibool_superbrick(1, 19) = 50
+ibool_superbrick(2, 19) = 49
+ibool_superbrick(3, 19) = 45
+ibool_superbrick(4, 19) = 47
+ibool_superbrick(5, 19) = 42
+ibool_superbrick(6, 19) = 38
+ibool_superbrick(7, 19) = 39
+ibool_superbrick(8, 19) = 43
+
+ibool_superbrick(1, 20) = 39
+ibool_superbrick(2, 20) = 21
+ibool_superbrick(3, 20) = 16
+ibool_superbrick(4, 20) = 45
+ibool_superbrick(5, 20) = 40
+ibool_superbrick(6, 20) = 22
+ibool_superbrick(7, 20) = 23
+ibool_superbrick(8, 20) = 46
+
+ibool_superbrick(1, 21) = 49
+ibool_superbrick(2, 21) = 13
+ibool_superbrick(3, 21) = 16
+ibool_superbrick(4, 21) = 45
+ibool_superbrick(5, 21) = 38
+ibool_superbrick(6, 21) = 19
+ibool_superbrick(7, 21) = 21
+ibool_superbrick(8, 21) = 39
+
+ibool_superbrick(1, 22) = 53
+ibool_superbrick(2, 22) = 51
+ibool_superbrick(3, 22) = 38
+ibool_superbrick(4, 22) = 42
+ibool_superbrick(5, 22) = 54
+ibool_superbrick(6, 22) = 52
+ibool_superbrick(7, 22) = 37
+ibool_superbrick(8, 22) = 41
+
+ibool_superbrick(1, 23) = 57
+ibool_superbrick(2, 23) = 55
+ibool_superbrick(3, 23) = 51
+ibool_superbrick(4, 23) = 53
+ibool_superbrick(5, 23) = 58
+ibool_superbrick(6, 23) = 56
+ibool_superbrick(7, 23) = 52
+ibool_superbrick(8, 23) = 54
+
+ibool_superbrick(1, 24) = 57
+ibool_superbrick(2, 24) = 32
+ibool_superbrick(3, 24) = 14
+ibool_superbrick(4, 24) = 50
+ibool_superbrick(5, 24) = 55
+ibool_superbrick(6, 24) = 33
+ibool_superbrick(7, 24) = 13
+ibool_superbrick(8, 24) = 49
+
+ibool_superbrick(1, 25) = 51
+ibool_superbrick(2, 25) = 34
+ibool_superbrick(3, 25) = 19
+ibool_superbrick(4, 25) = 38
+ibool_superbrick(5, 25) = 52
+ibool_superbrick(6, 25) = 35
+ibool_superbrick(7, 25) = 20
+ibool_superbrick(8, 25) = 37
+
+ibool_superbrick(1, 26) = 57
+ibool_superbrick(2, 26) = 55
+ibool_superbrick(3, 26) = 49
+ibool_superbrick(4, 26) = 50
+ibool_superbrick(5, 26) = 53
+ibool_superbrick(6, 26) = 51
+ibool_superbrick(7, 26) = 38
+ibool_superbrick(8, 26) = 42
+
+ibool_superbrick(1, 27) = 55
+ibool_superbrick(2, 27) = 33
+ibool_superbrick(3, 27) = 34
+ibool_superbrick(4, 27) = 51
+ibool_superbrick(5, 27) = 56
+ibool_superbrick(6, 27) = 36
+ibool_superbrick(7, 27) = 35
+ibool_superbrick(8, 27) = 52
+
+ibool_superbrick(1, 28) = 55
+ibool_superbrick(2, 28) = 33
+ibool_superbrick(3, 28) = 13
+ibool_superbrick(4, 28) = 49
+ibool_superbrick(5, 28) = 51
+ibool_superbrick(6, 28) = 34
+ibool_superbrick(7, 28) = 19
+ibool_superbrick(8, 28) = 38
+
+iboun_sb(:,:) = .false.
+iboun_sb(1,2) = .true.
+iboun_sb(1,6) = .true.
+iboun_sb(2,2) = .true.
+iboun_sb(2,4) = .true.
+iboun_sb(2,6) = .true.
+iboun_sb(3,4) = .true.
+iboun_sb(3,5) = .true.
+iboun_sb(4,6) = .true.
+iboun_sb(5,2) = .true.
+iboun_sb(6,4) = .true.
+iboun_sb(6,6) = .true.
+iboun_sb(8,2) = .true.
+iboun_sb(8,6) = .true.
+iboun_sb(9,2) = .true.
+iboun_sb(9,3) = .true.
+iboun_sb(9,6) = .true.
+iboun_sb(10,3) = .true.
+iboun_sb(10,5) = .true.
+iboun_sb(11,6) = .true.
+iboun_sb(12,2) = .true.
+iboun_sb(13,3) = .true.
+iboun_sb(13,6) = .true.
+iboun_sb(15,1) = .true.
+iboun_sb(15,6) = .true.
+iboun_sb(16,1) = .true.
+iboun_sb(16,4) = .true.
+iboun_sb(16,6) = .true.
+iboun_sb(17,4) = .true.
+iboun_sb(17,5) = .true.
+iboun_sb(18,6) = .true.
+iboun_sb(19,1) = .true.
+iboun_sb(20,4) = .true.
+iboun_sb(20,6) = .true.
+iboun_sb(22,1) = .true.
+iboun_sb(22,6) = .true.
+iboun_sb(23,1) = .true.
+iboun_sb(23,3) = .true.
+iboun_sb(23,6) = .true.
+iboun_sb(24,3) = .true.
+iboun_sb(24,5) = .true.
+iboun_sb(25,6) = .true.
+iboun_sb(26,1) = .true.
+iboun_sb(27,3) = .true.
+iboun_sb(27,6) = .true.
+
+end subroutine define_superbrick_one_layer
+
+
+subroutine define_basic_doubling_brick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb,case_num)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+ logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
+ integer :: case_num
+
+ SELECT CASE (case_num)
+ CASE (1)
+ x_superbrick(1) = 1.d0 / 2.d0
+ y_superbrick(1) = 1.d0
+ z_superbrick(1) = 2.d0
+
+ x_superbrick(2) = 1.d0 / 2.d0
+ y_superbrick(2) = 1.d0
+ z_superbrick(2) = 3.d0 / 2.d0
+
+ x_superbrick(3) = 1.d0 / 2.d0
+ y_superbrick(3) = 1.d0 / 2.d0
+ z_superbrick(3) = 3.d0 / 2.d0
+
+ x_superbrick(4) = 1.d0 / 2.d0
+ y_superbrick(4) = 1.d0 / 2.d0
+ z_superbrick(4) = 2.d0
+
+ x_superbrick(5) = 0.d0
+ y_superbrick(5) = 1.d0
+ z_superbrick(5) = 2.d0
+
+ x_superbrick(6) = 0.d0
+ y_superbrick(6) = 1.d0
+ z_superbrick(6) = 1.d0
+
+ x_superbrick(7) = 0.d0
+ y_superbrick(7) = 1.d0 / 2.d0
+ z_superbrick(7) = 1.d0
+
+ x_superbrick(8) = 0.d0
+ y_superbrick(8) = 1.d0 / 2.d0
+ z_superbrick(8) = 2.d0
+
+ x_superbrick(9) = 1.d0 / 2.d0
+ y_superbrick(9) = 0.d0
+ z_superbrick(9) = 1.d0
+
+ x_superbrick(10) = 1.d0 / 2.d0
+ y_superbrick(10) = 0.d0
+ z_superbrick(10) = 2.d0
+
+ x_superbrick(11) = 0.d0
+ y_superbrick(11) = 0.d0
+ z_superbrick(11) = 1.d0 / 2.d0
+
+ x_superbrick(12) = 0.d0
+ y_superbrick(12) = 0.d0
+ z_superbrick(12) = 2.d0
+
+ x_superbrick(13) = 1.d0
+ y_superbrick(13) = 1.d0
+ z_superbrick(13) = 1.d0
+
+ x_superbrick(14) = 1.d0
+ y_superbrick(14) = 1.d0
+ z_superbrick(14) = 1.d0 / 2.d0
+
+ x_superbrick(15) = 1.d0
+ y_superbrick(15) = 0.d0
+ z_superbrick(15) = 1.d0 / 2.d0
+
+ x_superbrick(16) = 1.d0
+ y_superbrick(16) = 0.d0
+ z_superbrick(16) = 1.d0
+
+ x_superbrick(17) = 1.d0 / 2.d0
+ y_superbrick(17) = 1.d0
+ z_superbrick(17) = 1.d0
+
+ x_superbrick(18) = 0.d0
+ y_superbrick(18) = 1.d0
+ z_superbrick(18) = 1.d0 / 2.d0
+
+ x_superbrick(19) = 1.d0
+ y_superbrick(19) = 1.d0
+ z_superbrick(19) = 3.d0 / 2.d0
+
+ x_superbrick(20) = 1.d0
+ y_superbrick(20) = 1.d0
+ z_superbrick(20) = 2.d0
+
+ x_superbrick(21) = 1.d0
+ y_superbrick(21) = 1.d0 / 2.d0
+ z_superbrick(21) = 3.d0 / 2.d0
+
+ x_superbrick(22) = 1.d0
+ y_superbrick(22) = 1.d0 / 2.d0
+ z_superbrick(22) = 2.d0
+
+ x_superbrick(23) = 1.d0
+ y_superbrick(23) = 0.d0
+ z_superbrick(23) = 2.d0
+
+ x_superbrick(24) = 1.d0
+ y_superbrick(24) = 1.d0
+ z_superbrick(24) = 0.d0
+
+ x_superbrick(25) = 0.d0
+ y_superbrick(25) = 1.d0
+ z_superbrick(25) = 0.d0
+
+ x_superbrick(26) = 0.d0
+ y_superbrick(26) = 0.d0
+ z_superbrick(26) = 0.d0
+
+ x_superbrick(27) = 1.d0
+ y_superbrick(27) = 0.d0
+ z_superbrick(27) = 0.d0
+
+ ibool_superbrick(1, 1) = 7
+ ibool_superbrick(2, 1) = 3
+ ibool_superbrick(3, 1) = 2
+ ibool_superbrick(4, 1) = 6
+ ibool_superbrick(5, 1) = 8
+ ibool_superbrick(6, 1) = 4
+ ibool_superbrick(7, 1) = 1
+ ibool_superbrick(8, 1) = 5
+
+ ibool_superbrick(1, 2) = 11
+ ibool_superbrick(2, 2) = 9
+ ibool_superbrick(3, 2) = 3
+ ibool_superbrick(4, 2) = 7
+ ibool_superbrick(5, 2) = 12
+ ibool_superbrick(6, 2) = 10
+ ibool_superbrick(7, 2) = 4
+ ibool_superbrick(8, 2) = 8
+
+ ibool_superbrick(1, 3) = 11
+ ibool_superbrick(2, 3) = 15
+ ibool_superbrick(3, 3) = 14
+ ibool_superbrick(4, 3) = 18
+ ibool_superbrick(5, 3) = 9
+ ibool_superbrick(6, 3) = 16
+ ibool_superbrick(7, 3) = 13
+ ibool_superbrick(8, 3) = 17
+
+ ibool_superbrick(1, 4) = 3
+ ibool_superbrick(2, 4) = 21
+ ibool_superbrick(3, 4) = 19
+ ibool_superbrick(4, 4) = 2
+ ibool_superbrick(5, 4) = 4
+ ibool_superbrick(6, 4) = 22
+ ibool_superbrick(7, 4) = 20
+ ibool_superbrick(8, 4) = 1
+
+ ibool_superbrick(1, 5) = 11
+ ibool_superbrick(2, 5) = 9
+ ibool_superbrick(3, 5) = 17
+ ibool_superbrick(4, 5) = 18
+ ibool_superbrick(5, 5) = 7
+ ibool_superbrick(6, 5) = 3
+ ibool_superbrick(7, 5) = 2
+ ibool_superbrick(8, 5) = 6
+
+ ibool_superbrick(1, 6) = 9
+ ibool_superbrick(2, 6) = 16
+ ibool_superbrick(3, 6) = 21
+ ibool_superbrick(4, 6) = 3
+ ibool_superbrick(5, 6) = 10
+ ibool_superbrick(6, 6) = 23
+ ibool_superbrick(7, 6) = 22
+ ibool_superbrick(8, 6) = 4
+
+ ibool_superbrick(1, 7) = 9
+ ibool_superbrick(2, 7) = 16
+ ibool_superbrick(3, 7) = 13
+ ibool_superbrick(4, 7) = 17
+ ibool_superbrick(5, 7) = 3
+ ibool_superbrick(6, 7) = 21
+ ibool_superbrick(7, 7) = 19
+ ibool_superbrick(8, 7) = 2
+
+ ibool_superbrick(1, 8) = 26
+ ibool_superbrick(2, 8) = 27
+ ibool_superbrick(3, 8) = 24
+ ibool_superbrick(4, 8) = 25
+ ibool_superbrick(5, 8) = 11
+ ibool_superbrick(6, 8) = 15
+ ibool_superbrick(7, 8) = 14
+ ibool_superbrick(8, 8) = 18
+
+ iboun_sb(:,:) = .false.
+ iboun_sb(1,1) = .true.
+ iboun_sb(1,4) = .true.
+ iboun_sb(1,6) = .true.
+ iboun_sb(2,1) = .true.
+ iboun_sb(2,3) = .true.
+ iboun_sb(2,6) = .true.
+ iboun_sb(3,2) = .true.
+ iboun_sb(3,3) = .true.
+ iboun_sb(3,4) = .true.
+ iboun_sb(4,2) = .true.
+ iboun_sb(4,4) = .true.
+ iboun_sb(4,6) = .true.
+ iboun_sb(5,1) = .true.
+ iboun_sb(5,4) = .true.
+ iboun_sb(6,2) = .true.
+ iboun_sb(6,3) = .true.
+ iboun_sb(6,6) = .true.
+ iboun_sb(7,2) = .true.
+ iboun_sb(7,4) = .true.
+ iboun_sb(8,1) = .true.
+ iboun_sb(8,2) = .true.
+ iboun_sb(8,3) = .true.
+ iboun_sb(8,4) = .true.
+ iboun_sb(8,5) = .true.
+ CASE (2)
+ x_superbrick(1) = 1.d0 / 2.d0
+ y_superbrick(1) = 0.d0
+ z_superbrick(1) = 2.d0
+
+ x_superbrick(2) = 1.d0 / 2.d0
+ y_superbrick(2) = 0.d0
+ z_superbrick(2) = 3.d0 / 2.d0
+
+ x_superbrick(3) = 1.d0 / 2.d0
+ y_superbrick(3) = 1.d0 / 2.d0
+ z_superbrick(3) = 3.d0 / 2.d0
+
+ x_superbrick(4) = 1.d0 / 2.d0
+ y_superbrick(4) = 1.d0 / 2.d0
+ z_superbrick(4) = 2.d0
+
+ x_superbrick(5) = 0.d0
+ y_superbrick(5) = 0.d0
+ z_superbrick(5) = 2.d0
+
+ x_superbrick(6) = 0.d0
+ y_superbrick(6) = 0.d0
+ z_superbrick(6) = 1.d0
+
+ x_superbrick(7) = 0.d0
+ y_superbrick(7) = 1.d0 / 2.d0
+ z_superbrick(7) = 1.d0
+
+ x_superbrick(8) = 0.d0
+ y_superbrick(8) = 1.d0 / 2.d0
+ z_superbrick(8) = 2.d0
+
+ x_superbrick(9) = 1.d0 / 2.d0
+ y_superbrick(9) = 1.d0
+ z_superbrick(9) = 1.d0
+
+ x_superbrick(10) = 1.d0 / 2.d0
+ y_superbrick(10) = 1.d0
+ z_superbrick(10) = 2.d0
+
+ x_superbrick(11) = 0.d0
+ y_superbrick(11) = 1.d0
+ z_superbrick(11) = 1.d0 / 2.d0
+
+ x_superbrick(12) = 0.d0
+ y_superbrick(12) = 1.d0
+ z_superbrick(12) = 2.d0
+
+ x_superbrick(13) = 1.d0
+ y_superbrick(13) = 0.d0
+ z_superbrick(13) = 1.d0
+
+ x_superbrick(14) = 1.d0
+ y_superbrick(14) = 0.d0
+ z_superbrick(14) = 1.d0 / 2.d0
+
+ x_superbrick(15) = 1.d0
+ y_superbrick(15) = 1.d0
+ z_superbrick(15) = 1.d0 / 2.d0
+
+ x_superbrick(16) = 1.d0
+ y_superbrick(16) = 1.d0
+ z_superbrick(16) = 1.d0
+
+ x_superbrick(17) = 1.d0 / 2.d0
+ y_superbrick(17) = 0.d0
+ z_superbrick(17) = 1.d0
+
+ x_superbrick(18) = 0.d0
+ y_superbrick(18) = 0.d0
+ z_superbrick(18) = 1.d0 / 2.d0
+
+ x_superbrick(19) = 1.d0
+ y_superbrick(19) = 0.d0
+ z_superbrick(19) = 3.d0 / 2.d0
+
+ x_superbrick(20) = 1.d0
+ y_superbrick(20) = 0.d0
+ z_superbrick(20) = 2.d0
+
+ x_superbrick(21) = 1.d0
+ y_superbrick(21) = 1.d0 / 2.d0
+ z_superbrick(21) = 3.d0 / 2.d0
+
+ x_superbrick(22) = 1.d0
+ y_superbrick(22) = 1.d0 / 2.d0
+ z_superbrick(22) = 2.d0
+
+ x_superbrick(23) = 1.d0
+ y_superbrick(23) = 1.d0
+ z_superbrick(23) = 2.d0
+
+ x_superbrick(24) = 1.d0
+ y_superbrick(24) = 0.d0
+ z_superbrick(24) = 0.d0
+
+ x_superbrick(25) = 0.d0
+ y_superbrick(25) = 0.d0
+ z_superbrick(25) = 0.d0
+
+ x_superbrick(26) = 0.d0
+ y_superbrick(26) = 1.d0
+ z_superbrick(26) = 0.d0
+
+ x_superbrick(27) = 1.d0
+ y_superbrick(27) = 1.d0
+ z_superbrick(27) = 0.d0
+
+ ibool_superbrick(1, 1) = 6
+ ibool_superbrick(2, 1) = 2
+ ibool_superbrick(3, 1) = 3
+ ibool_superbrick(4, 1) = 7
+ ibool_superbrick(5, 1) = 5
+ ibool_superbrick(6, 1) = 1
+ ibool_superbrick(7, 1) = 4
+ ibool_superbrick(8, 1) = 8
+
+ ibool_superbrick(1, 2) = 7
+ ibool_superbrick(2, 2) = 3
+ ibool_superbrick(3, 2) = 9
+ ibool_superbrick(4, 2) = 11
+ ibool_superbrick(5, 2) = 8
+ ibool_superbrick(6, 2) = 4
+ ibool_superbrick(7, 2) = 10
+ ibool_superbrick(8, 2) = 12
+
+ ibool_superbrick(1, 3) = 18
+ ibool_superbrick(2, 3) = 14
+ ibool_superbrick(3, 3) = 15
+ ibool_superbrick(4, 3) = 11
+ ibool_superbrick(5, 3) = 17
+ ibool_superbrick(6, 3) = 13
+ ibool_superbrick(7, 3) = 16
+ ibool_superbrick(8, 3) = 9
+
+ ibool_superbrick(1, 4) = 2
+ ibool_superbrick(2, 4) = 19
+ ibool_superbrick(3, 4) = 21
+ ibool_superbrick(4, 4) = 3
+ ibool_superbrick(5, 4) = 1
+ ibool_superbrick(6, 4) = 20
+ ibool_superbrick(7, 4) = 22
+ ibool_superbrick(8, 4) = 4
+
+ ibool_superbrick(1, 5) = 18
+ ibool_superbrick(2, 5) = 17
+ ibool_superbrick(3, 5) = 9
+ ibool_superbrick(4, 5) = 11
+ ibool_superbrick(5, 5) = 6
+ ibool_superbrick(6, 5) = 2
+ ibool_superbrick(7, 5) = 3
+ ibool_superbrick(8, 5) = 7
+
+ ibool_superbrick(1, 6) = 3
+ ibool_superbrick(2, 6) = 21
+ ibool_superbrick(3, 6) = 16
+ ibool_superbrick(4, 6) = 9
+ ibool_superbrick(5, 6) = 4
+ ibool_superbrick(6, 6) = 22
+ ibool_superbrick(7, 6) = 23
+ ibool_superbrick(8, 6) = 10
+
+ ibool_superbrick(1, 7) = 17
+ ibool_superbrick(2, 7) = 13
+ ibool_superbrick(3, 7) = 16
+ ibool_superbrick(4, 7) = 9
+ ibool_superbrick(5, 7) = 2
+ ibool_superbrick(6, 7) = 19
+ ibool_superbrick(7, 7) = 21
+ ibool_superbrick(8, 7) = 3
+
+ ibool_superbrick(1, 8) = 25
+ ibool_superbrick(2, 8) = 24
+ ibool_superbrick(3, 8) = 27
+ ibool_superbrick(4, 8) = 26
+ ibool_superbrick(5, 8) = 18
+ ibool_superbrick(6, 8) = 14
+ ibool_superbrick(7, 8) = 15
+ ibool_superbrick(8, 8) = 11
+
+ iboun_sb(:,:) = .false.
+ iboun_sb(1,1) = .true.
+ iboun_sb(1,3) = .true.
+ iboun_sb(1,6) = .true.
+ iboun_sb(2,1) = .true.
+ iboun_sb(2,4) = .true.
+ iboun_sb(2,6) = .true.
+ iboun_sb(3,2) = .true.
+ iboun_sb(3,3) = .true.
+ iboun_sb(3,4) = .true.
+ iboun_sb(4,2) = .true.
+ iboun_sb(4,3) = .true.
+ iboun_sb(4,6) = .true.
+ iboun_sb(5,1) = .true.
+ iboun_sb(5,3) = .true.
+ iboun_sb(6,2) = .true.
+ iboun_sb(6,4) = .true.
+ iboun_sb(6,6) = .true.
+ iboun_sb(7,2) = .true.
+ iboun_sb(7,3) = .true.
+ iboun_sb(8,1) = .true.
+ iboun_sb(8,2) = .true.
+ iboun_sb(8,3) = .true.
+ iboun_sb(8,4) = .true.
+ iboun_sb(8,5) = .true.
+ CASE (3)
+ x_superbrick(1) = 1.d0 / 2.d0
+ y_superbrick(1) = 1.d0
+ z_superbrick(1) = 2.d0
+
+ x_superbrick(2) = 1.d0 / 2.d0
+ y_superbrick(2) = 1.d0
+ z_superbrick(2) = 3.d0 / 2.d0
+
+ x_superbrick(3) = 1.d0 / 2.d0
+ y_superbrick(3) = 1.d0 / 2.d0
+ z_superbrick(3) = 3.d0 / 2.d0
+
+ x_superbrick(4) = 1.d0 / 2.d0
+ y_superbrick(4) = 1.d0 / 2.d0
+ z_superbrick(4) = 2.d0
+
+ x_superbrick(5) = 1.d0
+ y_superbrick(5) = 1.d0
+ z_superbrick(5) = 2.d0
+
+ x_superbrick(6) = 1.d0
+ y_superbrick(6) = 1.d0
+ z_superbrick(6) = 1.d0
+
+ x_superbrick(7) = 1.d0
+ y_superbrick(7) = 1.d0 / 2.d0
+ z_superbrick(7) = 1.d0
+
+ x_superbrick(8) = 1.d0
+ y_superbrick(8) = 1.d0 / 2.d0
+ z_superbrick(8) = 2.d0
+
+ x_superbrick(9) = 1.d0 / 2.d0
+ y_superbrick(9) = 0.d0
+ z_superbrick(9) = 1.d0
+
+ x_superbrick(10) = 1.d0 / 2.d0
+ y_superbrick(10) = 0.d0
+ z_superbrick(10) = 2.d0
+
+ x_superbrick(11) = 1.d0
+ y_superbrick(11) = 0.d0
+ z_superbrick(11) = 1.d0 / 2.d0
+
+ x_superbrick(12) = 1.d0
+ y_superbrick(12) = 0.d0
+ z_superbrick(12) = 2.d0
+
+ x_superbrick(13) = 0.d0
+ y_superbrick(13) = 1.d0
+ z_superbrick(13) = 1.d0
+
+ x_superbrick(14) = 0.d0
+ y_superbrick(14) = 1.d0
+ z_superbrick(14) = 1.d0 / 2.d0
+
+ x_superbrick(15) = 0.d0
+ y_superbrick(15) = 0.d0
+ z_superbrick(15) = 1.d0 / 2.d0
+
+ x_superbrick(16) = 0.d0
+ y_superbrick(16) = 0.d0
+ z_superbrick(16) = 1.d0
+
+ x_superbrick(17) = 1.d0 / 2.d0
+ y_superbrick(17) = 1.d0
+ z_superbrick(17) = 1.d0
+
+ x_superbrick(18) = 1.d0
+ y_superbrick(18) = 1.d0
+ z_superbrick(18) = 1.d0 / 2.d0
+
+ x_superbrick(19) = 0.d0
+ y_superbrick(19) = 1.d0
+ z_superbrick(19) = 3.d0 / 2.d0
+
+ x_superbrick(20) = 0.d0
+ y_superbrick(20) = 1.d0
+ z_superbrick(20) = 2.d0
+
+ x_superbrick(21) = 0.d0
+ y_superbrick(21) = 1.d0 / 2.d0
+ z_superbrick(21) = 3.d0 / 2.d0
+
+ x_superbrick(22) = 0.d0
+ y_superbrick(22) = 1.d0 / 2.d0
+ z_superbrick(22) = 2.d0
+
+ x_superbrick(23) = 0.d0
+ y_superbrick(23) = 0.d0
+ z_superbrick(23) = 2.d0
+
+ x_superbrick(24) = 0.d0
+ y_superbrick(24) = 1.d0
+ z_superbrick(24) = 0.d0
+
+ x_superbrick(25) = 1.d0
+ y_superbrick(25) = 1.d0
+ z_superbrick(25) = 0.d0
+
+ x_superbrick(26) = 1.d0
+ y_superbrick(26) = 0.d0
+ z_superbrick(26) = 0.d0
+
+ x_superbrick(27) = 0.d0
+ y_superbrick(27) = 0.d0
+ z_superbrick(27) = 0.d0
+
+ ibool_superbrick(1, 1) = 3
+ ibool_superbrick(2, 1) = 7
+ ibool_superbrick(3, 1) = 6
+ ibool_superbrick(4, 1) = 2
+ ibool_superbrick(5, 1) = 4
+ ibool_superbrick(6, 1) = 8
+ ibool_superbrick(7, 1) = 5
+ ibool_superbrick(8, 1) = 1
+
+ ibool_superbrick(1, 2) = 9
+ ibool_superbrick(2, 2) = 11
+ ibool_superbrick(3, 2) = 7
+ ibool_superbrick(4, 2) = 3
+ ibool_superbrick(5, 2) = 10
+ ibool_superbrick(6, 2) = 12
+ ibool_superbrick(7, 2) = 8
+ ibool_superbrick(8, 2) = 4
+
+ ibool_superbrick(1, 3) = 15
+ ibool_superbrick(2, 3) = 11
+ ibool_superbrick(3, 3) = 18
+ ibool_superbrick(4, 3) = 14
+ ibool_superbrick(5, 3) = 16
+ ibool_superbrick(6, 3) = 9
+ ibool_superbrick(7, 3) = 17
+ ibool_superbrick(8, 3) = 13
+
+ ibool_superbrick(1, 4) = 21
+ ibool_superbrick(2, 4) = 3
+ ibool_superbrick(3, 4) = 2
+ ibool_superbrick(4, 4) = 19
+ ibool_superbrick(5, 4) = 22
+ ibool_superbrick(6, 4) = 4
+ ibool_superbrick(7, 4) = 1
+ ibool_superbrick(8, 4) = 20
+
+ ibool_superbrick(1, 5) = 9
+ ibool_superbrick(2, 5) = 11
+ ibool_superbrick(3, 5) = 18
+ ibool_superbrick(4, 5) = 17
+ ibool_superbrick(5, 5) = 3
+ ibool_superbrick(6, 5) = 7
+ ibool_superbrick(7, 5) = 6
+ ibool_superbrick(8, 5) = 2
+
+ ibool_superbrick(1, 6) = 16
+ ibool_superbrick(2, 6) = 9
+ ibool_superbrick(3, 6) = 3
+ ibool_superbrick(4, 6) = 21
+ ibool_superbrick(5, 6) = 23
+ ibool_superbrick(6, 6) = 10
+ ibool_superbrick(7, 6) = 4
+ ibool_superbrick(8, 6) = 22
+
+ ibool_superbrick(1, 7) = 16
+ ibool_superbrick(2, 7) = 9
+ ibool_superbrick(3, 7) = 17
+ ibool_superbrick(4, 7) = 13
+ ibool_superbrick(5, 7) = 21
+ ibool_superbrick(6, 7) = 3
+ ibool_superbrick(7, 7) = 2
+ ibool_superbrick(8, 7) = 19
+
+ ibool_superbrick(1, 8) = 27
+ ibool_superbrick(2, 8) = 26
+ ibool_superbrick(3, 8) = 25
+ ibool_superbrick(4, 8) = 24
+ ibool_superbrick(5, 8) = 15
+ ibool_superbrick(6, 8) = 11
+ ibool_superbrick(7, 8) = 18
+ ibool_superbrick(8, 8) = 14
+
+ iboun_sb(:,:) = .false.
+ iboun_sb(1,2) = .true.
+ iboun_sb(1,4) = .true.
+ iboun_sb(1,6) = .true.
+ iboun_sb(2,2) = .true.
+ iboun_sb(2,3) = .true.
+ iboun_sb(2,6) = .true.
+ iboun_sb(3,1) = .true.
+ iboun_sb(3,3) = .true.
+ iboun_sb(3,4) = .true.
+ iboun_sb(4,1) = .true.
+ iboun_sb(4,4) = .true.
+ iboun_sb(4,6) = .true.
+ iboun_sb(5,2) = .true.
+ iboun_sb(5,4) = .true.
+ iboun_sb(6,1) = .true.
+ iboun_sb(6,3) = .true.
+ iboun_sb(6,6) = .true.
+ iboun_sb(7,1) = .true.
+ iboun_sb(7,4) = .true.
+ iboun_sb(8,1) = .true.
+ iboun_sb(8,2) = .true.
+ iboun_sb(8,3) = .true.
+ iboun_sb(8,4) = .true.
+ iboun_sb(8,5) = .true.
+ CASE (4)
+ x_superbrick(1) = 1.d0 / 2.d0
+ y_superbrick(1) = 0.d0
+ z_superbrick(1) = 2.d0
+
+ x_superbrick(2) = 1.d0 / 2.d0
+ y_superbrick(2) = 0.d0
+ z_superbrick(2) = 3.d0 / 2.d0
+
+ x_superbrick(3) = 1.d0 / 2.d0
+ y_superbrick(3) = 1.d0 / 2.d0
+ z_superbrick(3) = 3.d0 / 2.d0
+
+ x_superbrick(4) = 1.d0 / 2.d0
+ y_superbrick(4) = 1.d0 / 2.d0
+ z_superbrick(4) = 2.d0
+
+ x_superbrick(5) = 1.d0
+ y_superbrick(5) = 0.d0
+ z_superbrick(5) = 2.d0
+
+ x_superbrick(6) = 1.d0
+ y_superbrick(6) = 0.d0
+ z_superbrick(6) = 1.d0
+
+ x_superbrick(7) = 1.d0
+ y_superbrick(7) = 1.d0 / 2.d0
+ z_superbrick(7) = 1.d0
+
+ x_superbrick(8) = 1.d0
+ y_superbrick(8) = 1.d0 / 2.d0
+ z_superbrick(8) = 2.d0
+
+ x_superbrick(9) = 1.d0 / 2.d0
+ y_superbrick(9) = 1.d0
+ z_superbrick(9) = 1.d0
+
+ x_superbrick(10) = 1.d0 / 2.d0
+ y_superbrick(10) = 1.d0
+ z_superbrick(10) = 2.d0
+
+ x_superbrick(11) = 1.d0
+ y_superbrick(11) = 1.d0
+ z_superbrick(11) = 1.d0 / 2.d0
+
+ x_superbrick(12) = 1.d0
+ y_superbrick(12) = 1.d0
+ z_superbrick(12) = 2.d0
+
+ x_superbrick(13) = 0.d0
+ y_superbrick(13) = 0.d0
+ z_superbrick(13) = 1.d0
+
+ x_superbrick(14) = 0.d0
+ y_superbrick(14) = 0.d0
+ z_superbrick(14) = 1.d0 / 2.d0
+
+ x_superbrick(15) = 0.d0
+ y_superbrick(15) = 1.d0
+ z_superbrick(15) = 1.d0 / 2.d0
+
+ x_superbrick(16) = 0.d0
+ y_superbrick(16) = 1.d0
+ z_superbrick(16) = 1.d0
+
+ x_superbrick(17) = 1.d0 / 2.d0
+ y_superbrick(17) = 0.d0
+ z_superbrick(17) = 1.d0
+
+ x_superbrick(18) = 1.d0
+ y_superbrick(18) = 0.d0
+ z_superbrick(18) = 1.d0 / 2.d0
+
+ x_superbrick(19) = 0.d0
+ y_superbrick(19) = 0.d0
+ z_superbrick(19) = 3.d0 / 2.d0
+
+ x_superbrick(20) = 0.d0
+ y_superbrick(20) = 0.d0
+ z_superbrick(20) = 2.d0
+
+ x_superbrick(21) = 0.d0
+ y_superbrick(21) = 1.d0 / 2.d0
+ z_superbrick(21) = 3.d0 / 2.d0
+
+ x_superbrick(22) = 0.d0
+ y_superbrick(22) = 1.d0 / 2.d0
+ z_superbrick(22) = 2.d0
+
+ x_superbrick(23) = 0.d0
+ y_superbrick(23) = 1.d0
+ z_superbrick(23) = 2.d0
+
+ x_superbrick(24) = 0.d0
+ y_superbrick(24) = 0.d0
+ z_superbrick(24) = 0.d0
+
+ x_superbrick(25) = 1.d0
+ y_superbrick(25) = 0.d0
+ z_superbrick(25) = 0.d0
+
+ x_superbrick(26) = 1.d0
+ y_superbrick(26) = 1.d0
+ z_superbrick(26) = 0.d0
+
+ x_superbrick(27) = 0.d0
+ y_superbrick(27) = 1.d0
+ z_superbrick(27) = 0.d0
+
+ ibool_superbrick(1, 1) = 2
+ ibool_superbrick(2, 1) = 6
+ ibool_superbrick(3, 1) = 7
+ ibool_superbrick(4, 1) = 3
+ ibool_superbrick(5, 1) = 1
+ ibool_superbrick(6, 1) = 5
+ ibool_superbrick(7, 1) = 8
+ ibool_superbrick(8, 1) = 4
+
+ ibool_superbrick(1, 2) = 3
+ ibool_superbrick(2, 2) = 7
+ ibool_superbrick(3, 2) = 11
+ ibool_superbrick(4, 2) = 9
+ ibool_superbrick(5, 2) = 4
+ ibool_superbrick(6, 2) = 8
+ ibool_superbrick(7, 2) = 12
+ ibool_superbrick(8, 2) = 10
+
+ ibool_superbrick(1, 3) = 14
+ ibool_superbrick(2, 3) = 18
+ ibool_superbrick(3, 3) = 11
+ ibool_superbrick(4, 3) = 15
+ ibool_superbrick(5, 3) = 13
+ ibool_superbrick(6, 3) = 17
+ ibool_superbrick(7, 3) = 9
+ ibool_superbrick(8, 3) = 16
+
+ ibool_superbrick(1, 4) = 19
+ ibool_superbrick(2, 4) = 2
+ ibool_superbrick(3, 4) = 3
+ ibool_superbrick(4, 4) = 21
+ ibool_superbrick(5, 4) = 20
+ ibool_superbrick(6, 4) = 1
+ ibool_superbrick(7, 4) = 4
+ ibool_superbrick(8, 4) = 22
+
+ ibool_superbrick(1, 5) = 17
+ ibool_superbrick(2, 5) = 18
+ ibool_superbrick(3, 5) = 11
+ ibool_superbrick(4, 5) = 9
+ ibool_superbrick(5, 5) = 2
+ ibool_superbrick(6, 5) = 6
+ ibool_superbrick(7, 5) = 7
+ ibool_superbrick(8, 5) = 3
+
+ ibool_superbrick(1, 6) = 21
+ ibool_superbrick(2, 6) = 3
+ ibool_superbrick(3, 6) = 9
+ ibool_superbrick(4, 6) = 16
+ ibool_superbrick(5, 6) = 22
+ ibool_superbrick(6, 6) = 4
+ ibool_superbrick(7, 6) = 10
+ ibool_superbrick(8, 6) = 23
+
+ ibool_superbrick(1, 7) = 13
+ ibool_superbrick(2, 7) = 17
+ ibool_superbrick(3, 7) = 9
+ ibool_superbrick(4, 7) = 16
+ ibool_superbrick(5, 7) = 19
+ ibool_superbrick(6, 7) = 2
+ ibool_superbrick(7, 7) = 3
+ ibool_superbrick(8, 7) = 21
+
+ ibool_superbrick(1, 8) = 24
+ ibool_superbrick(2, 8) = 25
+ ibool_superbrick(3, 8) = 26
+ ibool_superbrick(4, 8) = 27
+ ibool_superbrick(5, 8) = 14
+ ibool_superbrick(6, 8) = 18
+ ibool_superbrick(7, 8) = 11
+ ibool_superbrick(8, 8) = 15
+
+ iboun_sb(:,:) = .false.
+ iboun_sb(1,2) = .true.
+ iboun_sb(1,3) = .true.
+ iboun_sb(1,6) = .true.
+ iboun_sb(2,2) = .true.
+ iboun_sb(2,4) = .true.
+ iboun_sb(2,6) = .true.
+ iboun_sb(3,1) = .true.
+ iboun_sb(3,3) = .true.
+ iboun_sb(3,4) = .true.
+ iboun_sb(4,1) = .true.
+ iboun_sb(4,3) = .true.
+ iboun_sb(4,6) = .true.
+ iboun_sb(5,2) = .true.
+ iboun_sb(5,3) = .true.
+ iboun_sb(6,1) = .true.
+ iboun_sb(6,4) = .true.
+ iboun_sb(6,6) = .true.
+ iboun_sb(7,1) = .true.
+ iboun_sb(7,3) = .true.
+ iboun_sb(8,1) = .true.
+ iboun_sb(8,2) = .true.
+ iboun_sb(8,3) = .true.
+ iboun_sb(8,4) = .true.
+ iboun_sb(8,5) = .true.
+ END SELECT
+end subroutine define_basic_doubling_brick
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/euler_angles.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/euler_angles.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/euler_angles.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/euler_angles.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,66 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! compute the Euler angles and the associated rotation matrix
+
+ subroutine euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision rotation_matrix(3,3)
+ double precision CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH
+
+ double precision alpha,beta,gamma
+ double precision sina,cosa,sinb,cosb,sing,cosg
+
+! compute colatitude and longitude and convert to radians
+ alpha = CENTER_LONGITUDE_IN_DEGREES * DEGREES_TO_RADIANS
+ beta = (90.0d0 - CENTER_LATITUDE_IN_DEGREES) * DEGREES_TO_RADIANS
+ gamma = GAMMA_ROTATION_AZIMUTH * DEGREES_TO_RADIANS
+
+ sina = dsin(alpha)
+ cosa = dcos(alpha)
+ sinb = dsin(beta)
+ cosb = dcos(beta)
+ sing = dsin(gamma)
+ cosg = dcos(gamma)
+
+! define rotation matrix
+ rotation_matrix(1,1) = cosg*cosb*cosa-sing*sina
+ rotation_matrix(1,2) = -sing*cosb*cosa-cosg*sina
+ rotation_matrix(1,3) = sinb*cosa
+ rotation_matrix(2,1) = cosg*cosb*sina+sing*cosa
+ rotation_matrix(2,2) = -sing*cosb*sina+cosg*cosa
+ rotation_matrix(2,3) = sinb*sina
+ rotation_matrix(3,1) = -cosg*sinb
+ rotation_matrix(3,2) = sing*sinb
+ rotation_matrix(3,3) = cosb
+
+ end subroutine euler_angles
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,98 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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')
+ 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_MPI_1D_buffers.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_1D_buffers.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_1D_buffers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_1D_buffers.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,482 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_MPI_1D_buffers(myrank,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
+ idoubling,xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion,nglob_ori, &
+ 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)
+
+! routine to create the MPI 1D chunk buffers for edges
+
+ implicit none
+
+ include "constants.h"
+
+ 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)
+
+!! DK DK added this for merged version
+ integer :: iregion_code
+ 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 nspec,myrank,nglob_ori,nglob,ipoin1D,iregion
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+
+ logical iMPIcut_xi(2,nspec)
+ logical iMPIcut_eta(2,nspec)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to create arrays ibool1D
+ integer npointot
+ logical mask_ibool(npointot)
+
+! global element numbering
+ integer ispec
+
+! MPI 1D buffer element numbering
+ integer ispeccount,npoin1D,ix,iy,iz
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+ integer, dimension(:), allocatable :: ibool_selected
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+
+! allocate arrays for message buffers with maximum size
+! define maximum size for message buffers
+ if (PERFORM_CUTHILL_MCKEE) then
+ allocate(ibool_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(xstore_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(ystore_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(zstore_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(ind(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(ninseg(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(iglob(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(locval(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(ifseg(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(iwork(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(work(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ endif
+
+! write the MPI buffers for the left and right edges of the slice
+! and the position of the points to check that the buffers are fine
+
+! *****************************************************************
+! ****************** generate for eta = eta_min *******************
+! *****************************************************************
+
+! determine if the element falls on the left MPI cut plane
+
+! global point number and coordinates left MPI 1D buffer
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin1D = 0
+
+! nb of elements in this 1D buffer
+ ispeccount=0
+
+ do ispec=1,nspec
+ ! remove central cube for chunk buffers
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ 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
+ ! corner detection here
+ if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(1,ispec)) then
+ ispeccount=ispeccount+1
+ ! loop on all the points
+ ix = 1
+ iy = 1
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+ ibool1D_leftxi_lefteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xread1D_leftxi_lefteta(npoin1D) = xstore(ix,iy,iz,ispec)
+ yread1D_leftxi_lefteta(npoin1D) = ystore(ix,iy,iz,ispec)
+ zread1D_leftxi_lefteta(npoin1D) = zstore(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+
+ do ipoin1D=1,npoin1D
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
+!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
+!! DK DK added this for merged
+ ibool1D_leftxi_lefteta(ipoin1D) = ibool_selected(ipoin1D)
+ xread1D_leftxi_lefteta(ipoin1D) = xstore_selected(ipoin1D)
+ yread1D_leftxi_lefteta(ipoin1D) = ystore_selected(ipoin1D)
+ zread1D_leftxi_lefteta(ipoin1D) = zstore_selected(ipoin1D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin1D
+
+!! DK DK suppressed merged close(10)
+
+! compare number of edge elements detected to analytical value
+ if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,1) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,1)) &
+ call exit_MPI(myrank,'error MPI 1D buffer detection in xi=left')
+
+! determine if the element falls on the right MPI cut plane
+
+! global point number and coordinates right MPI 1D buffer
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin1D = 0
+
+! nb of elements in this 1D buffer
+ ispeccount=0
+ do ispec=1,nspec
+ ! remove central cube for chunk buffers
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ 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
+ ! corner detection here
+ if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(1,ispec)) then
+ ispeccount=ispeccount+1
+ ! loop on all the points
+ ix = NGLLX
+ iy = 1
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+ ibool1D_rightxi_lefteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xread1D_rightxi_lefteta(npoin1D) = xstore(ix,iy,iz,ispec)
+ yread1D_rightxi_lefteta(npoin1D) = ystore(ix,iy,iz,ispec)
+ zread1D_rightxi_lefteta(npoin1D) = zstore(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+
+ do ipoin1D=1,npoin1D
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
+!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
+!! DK DK added this for merged
+ ibool1D_rightxi_lefteta(ipoin1D) = ibool_selected(ipoin1D)
+ xread1D_rightxi_lefteta(ipoin1D) = xstore_selected(ipoin1D)
+ yread1D_rightxi_lefteta(ipoin1D) = ystore_selected(ipoin1D)
+ zread1D_rightxi_lefteta(ipoin1D) = zstore_selected(ipoin1D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin1D
+
+!! DK DK suppressed merged close(10)
+
+! compare number of edge elements and points detected to analytical value
+ if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,2) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,2)) &
+ call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right')
+
+! *****************************************************************
+! ****************** generate for eta = eta_max *******************
+! *****************************************************************
+
+! determine if the element falls on the left MPI cut plane
+
+! global point number and coordinates left MPI 1D buffer
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin1D = 0
+
+! nb of elements in this 1D buffer
+ ispeccount=0
+
+ do ispec=1,nspec
+
+! remove central cube for chunk buffers
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ 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
+
+! corner detection here
+ if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(2,ispec)) then
+
+ ispeccount=ispeccount+1
+
+! loop on all the points
+ ix = 1
+ iy = NGLLY
+ do iz=1,NGLLZ
+
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+ ibool1D_leftxi_righteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xread1D_leftxi_righteta(npoin1D) = xstore(ix,iy,iz,ispec)
+ yread1D_leftxi_righteta(npoin1D) = ystore(ix,iy,iz,ispec)
+ zread1D_leftxi_righteta(npoin1D) = zstore(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+
+ do ipoin1D=1,npoin1D
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
+!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
+!! DK DK added this for merged
+ ibool1D_leftxi_righteta(ipoin1D) = ibool_selected(ipoin1D)
+ xread1D_leftxi_righteta(ipoin1D) = xstore_selected(ipoin1D)
+ yread1D_leftxi_righteta(ipoin1D) = ystore_selected(ipoin1D)
+ zread1D_leftxi_righteta(ipoin1D) = zstore_selected(ipoin1D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin1D
+
+!! DK DK suppressed merged close(10)
+
+! compare number of edge elements detected to analytical value
+ if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,4) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,4)) &
+ call exit_MPI(myrank,'error MPI 1D buffer detection in xi=left')
+
+! determine if the element falls on the right MPI cut plane
+
+! global point number and coordinates right MPI 1D buffer
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin1D = 0
+
+! nb of elements in this 1D buffer
+ ispeccount=0
+
+ do ispec=1,nspec
+
+! remove central cube for chunk buffers
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ 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
+
+! corner detection here
+ if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(2,ispec)) then
+
+ ispeccount=ispeccount+1
+
+! loop on all the points
+ ix = NGLLX
+ iy = NGLLY
+ do iz=1,NGLLZ
+
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ ibool1D_rightxi_righteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xread1D_rightxi_righteta(npoin1D) = xstore(ix,iy,iz,ispec)
+ yread1D_rightxi_righteta(npoin1D) = ystore(ix,iy,iz,ispec)
+ zread1D_rightxi_righteta(npoin1D) = zstore(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+
+ do ipoin1D=1,npoin1D
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
+!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
+!! DK DK added this for merged
+ ibool1D_rightxi_righteta(ipoin1D) = ibool_selected(ipoin1D)
+ xread1D_rightxi_righteta(ipoin1D) = xstore_selected(ipoin1D)
+ yread1D_rightxi_righteta(ipoin1D) = ystore_selected(ipoin1D)
+ zread1D_rightxi_righteta(ipoin1D) = zstore_selected(ipoin1D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin1D
+
+!! DK DK suppressed merged close(10)
+
+! compare number of edge elements and points detected to analytical value
+ if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,3) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,3)) &
+ call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right')
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ deallocate(ibool_selected)
+ deallocate(xstore_selected)
+ deallocate(ystore_selected)
+ deallocate(zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+ endif
+
+ end subroutine get_MPI_1D_buffers
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_cutplanes_eta.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_eta.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_cutplanes_eta.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_cutplanes_eta.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,267 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_MPI_cutplanes_eta(myrank,nspec,iMPIcut_eta,ibool, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_XI_FACE,iregion,NGLOB2DMAX_XY,nglob_ori,iboolleft_eta,iboolright_eta,NGLOB2DMAX_YMIN_YMAX,npoin2D_eta)
+
+! this routine detects cut planes along eta
+! In principle the left cut plane of the first slice
+! and the right cut plane of the last slice are not used
+! in the solver except if we want to have periodic conditions
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NGLOB2DMAX_YMIN_YMAX
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+
+ integer nspec,myrank,nglob_ori,nglob,ipoin2D,NGLOB2DMAX_XY,iregion
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE
+
+ logical iMPIcut_eta(2,nspec)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to create arrays iboolleft_eta and iboolright_eta
+ integer npointot
+ logical mask_ibool(npointot)
+
+! global element numbering
+ integer ispec
+
+! MPI cut-plane element numbering
+ integer ispecc1,ispecc2,npoin2D_eta,ix,iy,iz
+ integer nspec2Dtheor
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+ integer, dimension(:), allocatable :: ibool_selected
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+
+
+! allocate arrays for message buffers with maximum size
+! define maximum size for message buffers
+ if (PERFORM_CUTHILL_MCKEE) then
+ allocate(ibool_selected(NGLOB2DMAX_XY))
+ allocate(xstore_selected(NGLOB2DMAX_XY))
+ allocate(ystore_selected(NGLOB2DMAX_XY))
+ allocate(zstore_selected(NGLOB2DMAX_XY))
+ allocate(ind(NGLOB2DMAX_XY))
+ allocate(ninseg(NGLOB2DMAX_XY))
+ allocate(iglob(NGLOB2DMAX_XY))
+ allocate(locval(NGLOB2DMAX_XY))
+ allocate(ifseg(NGLOB2DMAX_XY))
+ allocate(iwork(NGLOB2DMAX_XY))
+ allocate(work(NGLOB2DMAX_XY))
+ endif
+
+! theoretical number of surface elements in the buffers
+! cut planes along eta=constant correspond to XI faces
+ nspec2Dtheor = NSPEC2D_XI_FACE(iregion,1)
+
+! write the MPI buffers for the left and right edges of the slice
+! and the position of the points to check that the buffers are fine
+
+!
+! determine if the element falls on the left MPI cut plane
+!
+
+! global point number and coordinates left MPI cut-plane
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_eta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_eta = 0
+
+! nb of elements in this cut-plane
+ ispecc1=0
+
+ do ispec=1,nspec
+ if(iMPIcut_eta(1,ispec)) then
+ ispecc1=ispecc1+1
+ ! loop on all the points in that 2-D element, including edges
+ iy = 1
+ do ix=1,NGLLX
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_eta = npoin2D_eta + 1
+!! DK DK added this for merged
+ if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_eta) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_eta) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_eta) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
+!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
+ iboolleft_eta(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin2D_eta,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged
+ if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
+
+ do ipoin2D=1,npoin2D_eta
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
+!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+!! DK DK added this for merged
+!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
+!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
+ iboolleft_eta(ipoin2D) = ibool_selected(ipoin2D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin2D_eta
+
+!! DK DK suppressed merged close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc1 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=left')
+
+!
+! determine if the element falls on the right MPI cut plane
+!
+ nspec2Dtheor = NSPEC2D_XI_FACE(iregion,2)
+
+! global point number and coordinates right MPI cut-plane
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_eta = 0
+
+! nb of elements in this cut-plane
+ ispecc2=0
+
+ do ispec=1,nspec
+ if(iMPIcut_eta(2,ispec)) then
+ ispecc2=ispecc2+1
+ ! loop on all the points in that 2-D element, including edges
+ iy = NGLLY
+ do ix=1,NGLLX
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_eta = npoin2D_eta + 1
+!! DK DK added this for merged
+ if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_eta) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_eta) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_eta) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
+!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
+ iboolright_eta(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin2D_eta,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged
+ if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
+
+ do ipoin2D=1,npoin2D_eta
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
+!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+!! DK DK added this for merged
+!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
+!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
+ iboolright_eta(ipoin2D) = ibool_selected(ipoin2D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin2D_eta
+
+!! DK DK suppressed merged close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc2 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=right')
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ deallocate(ibool_selected)
+ deallocate(xstore_selected)
+ deallocate(ystore_selected)
+ deallocate(zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+ endif
+
+ end subroutine get_MPI_cutplanes_eta
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_cutplanes_xi.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_xi.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_cutplanes_xi.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_MPI_cutplanes_xi.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,266 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_MPI_cutplanes_xi(myrank,nspec,iMPIcut_xi,ibool, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_ETA_FACE,iregion,NGLOB2DMAX_XY,nglob_ori,iboolleft_xi,iboolright_xi,NGLOB2DMAX_XMIN_XMAX,npoin2D_xi)
+
+! this routine detects cut planes along xi
+! In principle the left cut plane of the first slice
+! and the right cut plane of the last slice are not used
+! in the solver except if we want to have periodic conditions
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NGLOB2DMAX_XMIN_XMAX
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+
+ integer nspec,myrank,nglob_ori,nglob,ipoin2D,iregion
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_ETA_FACE
+
+ logical iMPIcut_xi(2,nspec)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to create arrays iboolleft_xi and iboolright_xi
+ integer npointot
+ logical mask_ibool(npointot)
+
+! global element numbering
+ integer ispec
+
+! MPI cut-plane element numbering
+ integer ispecc1,ispecc2,npoin2D_xi,ix,iy,iz
+ integer nspec2Dtheor
+
+ character(len=150) errmsg
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+ integer NGLOB2DMAX_XY
+ integer, dimension(:), allocatable :: ibool_selected
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+
+! allocate arrays for message buffers with maximum size
+! define maximum size for message buffers
+ if (PERFORM_CUTHILL_MCKEE) then
+ allocate(ibool_selected(NGLOB2DMAX_XY))
+ allocate(xstore_selected(NGLOB2DMAX_XY))
+ allocate(ystore_selected(NGLOB2DMAX_XY))
+ allocate(zstore_selected(NGLOB2DMAX_XY))
+ allocate(ind(NGLOB2DMAX_XY))
+ allocate(ninseg(NGLOB2DMAX_XY))
+ allocate(iglob(NGLOB2DMAX_XY))
+ allocate(locval(NGLOB2DMAX_XY))
+ allocate(ifseg(NGLOB2DMAX_XY))
+ allocate(iwork(NGLOB2DMAX_XY))
+ allocate(work(NGLOB2DMAX_XY))
+ endif
+
+
+! theoretical number of surface elements in the buffers
+! cut planes along xi=constant correspond to ETA faces
+ nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,1)
+! write the MPI buffers for the left and right edges of the slice
+! and the position of the points to check that the buffers are fine
+
+!
+! determine if the element falls on the left MPI cut plane
+!
+
+! global point number and coordinates left MPI cut-plane
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_xi.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_xi = 0
+
+! nb of elements in this cut-plane
+ ispecc1=0
+
+ do ispec=1,nspec
+ if(iMPIcut_xi(1,ispec)) then
+ ispecc1=ispecc1+1
+ ! loop on all the points in that 2-D element, including edges
+ ix = 1
+ do iy=1,NGLLY
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
+!! DK DK added this for merged
+ if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_xi) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_xi) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_xi) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+ iboolleft_xi(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin2D_xi,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged
+ if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
+
+ do ipoin2D=1,npoin2D_xi
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
+!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+!! DK DK added this for merged
+!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
+!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
+ iboolleft_xi(ipoin2D) = ibool_selected(ipoin2D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin2D_xi
+
+!! DK DK suppressed merged close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc1 /= nspec2Dtheor) then
+ write(errmsg,*) 'error MPI cut-planes detection in xi=left T=',nspec2Dtheor,' C=',ispecc1
+ call exit_MPI(myrank,errmsg)
+ endif
+!
+! determine if the element falls on the right MPI cut plane
+!
+ nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,2)
+
+! global point number and coordinates right MPI cut-plane
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolright_xi.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_xi = 0
+
+! nb of elements in this cut-plane
+ ispecc2=0
+
+ do ispec=1,nspec
+ if(iMPIcut_xi(2,ispec)) then
+ ispecc2=ispecc2+1
+ ! loop on all the points in that 2-D element, including edges
+ ix = NGLLX
+ do iy=1,NGLLY
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
+!! DK DK added this for merged
+ if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_xi) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_xi) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_xi) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ iboolright_xi(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin2D_xi,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged
+ if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
+
+ do ipoin2D=1,npoin2D_xi
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
+!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+ iboolright_xi(ipoin2D) = ibool_selected(ipoin2D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin2D_xi
+
+!! DK DK suppressed merged close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc2 /= nspec2Dtheor) then
+ write(errmsg,*) 'error MPI cut-planes detection in xi=right T=',nspec2Dtheor,' C=',ispecc2
+ call exit_MPI(myrank,errmsg)
+ endif
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ deallocate(ibool_selected)
+ deallocate(xstore_selected)
+ deallocate(ystore_selected)
+ deallocate(zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+ endif
+
+ end subroutine get_MPI_cutplanes_xi
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_cmt.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_cmt.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_cmt.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_cmt.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,189 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,NSOURCES)
+
+ implicit none
+
+ include "constants.h"
+
+!--- input or output arguments of the subroutine below
+
+ integer, intent(in) :: NSOURCES
+ double precision, intent(in) :: DT
+
+ integer, intent(out) :: yr,jda,ho,mi
+ double precision, intent(out) :: sec
+ double precision, dimension(NSOURCES), intent(out) :: t_cmt,hdur,lat,long,depth
+ double precision, dimension(6,NSOURCES), intent(out) :: moment_tensor
+
+!--- local variables below
+
+ integer mo,da,julian_day,isource
+ double precision scaleM
+ character(len=5) datasource
+ character(len=150) string, CMTSOLUTION
+
+!
+!---- read hypocenter info
+!
+ call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
+
+ open(unit=1,file=CMTSOLUTION,status='old',action='read')
+
+! read source number isource
+ do isource=1,NSOURCES
+
+! read header with event information
+ read(1,"(a4,i5,i3,i3,i3,i3,f6.2)") datasource,yr,mo,da,ho,mi,sec
+ jda=julian_day(yr,mo,da)
+
+! ignore line with event name
+ read(1,"(a)") string
+
+! read time shift
+ read(1,"(a)") string
+ read(string(12:len_trim(string)),*) t_cmt(isource)
+
+! read half duration
+ read(1,"(a)") string
+ read(string(15:len_trim(string)),*) hdur(isource)
+
+! read latitude
+ read(1,"(a)") string
+ read(string(10:len_trim(string)),*) lat(isource)
+
+! read longitude
+ read(1,"(a)") string
+ read(string(11:len_trim(string)),*) long(isource)
+
+! read depth
+ read(1,"(a)") string
+ read(string(7:len_trim(string)),*) depth(isource)
+
+! read Mrr
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(1,isource)
+
+! read Mtt
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(2,isource)
+
+! read Mpp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(3,isource)
+
+! read Mrt
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(4,isource)
+
+! read Mrp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(5,isource)
+
+! read Mtp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(6,isource)
+
+! null half-duration indicates a Heaviside
+! replace with very short error function
+ if(hdur(isource) < 5. * DT) hdur(isource) = 5. * DT
+
+ enddo
+
+ close(1)
+
+!
+! scale and non-dimensionalize the moment tensor
+! CMTSOLUTION file values are in dyne.cm
+! 1 dyne is 1 gram * 1 cm / (1 second)^2
+! 1 Newton is 1 kg * 1 m / (1 second)^2
+! thus 1 Newton = 100,000 dynes
+! therefore 1 dyne.cm = 1e-7 Newton.m
+!
+ scaleM = 1.d7 * RHOAV * (R_EARTH**5) * PI*GRAV*RHOAV
+ moment_tensor(:,:) = moment_tensor(:,:) / scaleM
+
+ end subroutine get_cmt
+
+! ------------------------------------------------------------------
+
+ integer function julian_day(yr,mo,da)
+
+ implicit none
+
+ integer yr,mo,da
+
+ integer mon(12)
+ integer lpyr
+ data mon /0,31,59,90,120,151,181,212,243,273,304,334/
+
+ julian_day = da + mon(mo)
+ if(mo>2) julian_day = julian_day + lpyr(yr)
+
+ end function julian_day
+
+! ------------------------------------------------------------------
+
+ integer function lpyr(yr)
+
+ implicit none
+
+ integer yr
+!
+!---- returns 1 if leap year
+!
+ lpyr=0
+ if(mod(yr,400) == 0) then
+ lpyr=1
+ else if(mod(yr,4) == 0) then
+ lpyr=1
+ if(mod(yr,100) == 0) lpyr=0
+ endif
+
+ end function lpyr
+
+! ------------------------------------------------------------------
+
+! function to determine if year is a leap year
+ logical function is_leap_year(yr)
+
+ implicit none
+
+ integer yr
+
+ integer, external :: lpyr
+
+!---- function lpyr above returns 1 if leap year
+ if(lpyr(yr) == 1) then
+ is_leap_year = .true.
+ else
+ is_leap_year = .false.
+ endif
+
+ end function is_leap_year
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_ellipticity.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_ellipticity.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_ellipticity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_ellipticity.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,65 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspl
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ integer ia
+
+ double precision ell
+ double precision r,theta,phi,factor
+ double precision cost,p20
+
+ do ia=1,NGNOD
+
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+
+ cost=dcos(theta)
+ p20=0.5d0*(3.0d0*cost*cost-1.0d0)
+
+! get ellipticity using spline evaluation
+ call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
+
+ factor=ONE-(TWO/3.0d0)*ell*p20
+
+ xelm(ia)=xelm(ia)*factor
+ yelm(ia)=yelm(ia)*factor
+ zelm(ia)=zelm(ia)*factor
+
+ enddo
+
+ end subroutine get_ellipticity
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,193 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_global.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_global.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_global.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_global.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,234 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_global(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot)
+
+! this routine MUST be in double precision to avoid sensitivity
+! to roundoff errors in the coordinates of the points
+
+! non-structured global numbering software provided by Paul F. Fischer
+
+! leave sorting subroutines in same source file to allow for inlining
+
+ implicit none
+
+ include "constants.h"
+
+! parameters
+ integer, intent(in) :: npointot,nspec
+ double precision, intent(in) :: xp(npointot),yp(npointot),zp(npointot)
+
+ integer, intent(out) :: iglob(npointot),loc(npointot)
+ logical, intent(out) :: ifseg(npointot)
+ integer, intent(out) :: nglob
+
+! variables
+ integer ispec,i,j
+ integer ieoff,ilocnum,nseg,ioff,iseg,ig
+
+ integer, dimension(:), allocatable :: ind,ninseg,iwork
+ double precision, dimension(:), allocatable :: work
+
+! dynamically allocate arrays
+ allocate(ind(npointot))
+ allocate(ninseg(npointot))
+ allocate(iwork(npointot))
+ allocate(work(npointot))
+
+! establish initial pointers
+ do ispec=1,nspec
+ ieoff=NGLLX * NGLLY * NGLLZ * (ispec-1)
+ do ilocnum=1,NGLLX * NGLLY * NGLLZ
+ loc(ilocnum+ieoff)=ilocnum+ieoff
+ enddo
+ enddo
+
+ ifseg(:)=.false.
+
+ nseg=1
+ ifseg(1)=.true.
+ ninseg(1)=npointot
+
+do j=1,NDIM
+
+ ! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+ call rank(xp(ioff),ind,ninseg(iseg))
+ else if(j == 2) then
+ call rank(yp(ioff),ind,ninseg(iseg))
+ else
+ call rank(zp(ioff),ind,ninseg(iseg))
+ endif
+ call swap_all(loc(ioff),xp(ioff),yp(ioff),zp(ioff),iwork,work,ind,ninseg(iseg))
+ ioff=ioff+ninseg(iseg)
+ enddo
+
+! check for jumps in current coordinate
+! compare the coordinates of the points within a small tolerance
+ if(j == 1) then
+ do i=2,npointot
+ if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ enddo
+ else if(j == 2) then
+ do i=2,npointot
+ if(dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ enddo
+ else
+ do i=2,npointot
+ if(dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ enddo
+ endif
+
+! count up number of different segments
+ nseg=0
+ do i=1,npointot
+ if(ifseg(i)) then
+ nseg=nseg+1
+ ninseg(nseg)=1
+ else
+ ninseg(nseg)=ninseg(nseg)+1
+ endif
+ enddo
+enddo
+
+! assign global node numbers (now sorted lexicographically)
+ ig=0
+ do i=1,npointot
+ if(ifseg(i)) ig=ig+1
+ iglob(loc(i))=ig
+ enddo
+
+ nglob=ig
+
+! deallocate arrays
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iwork)
+ deallocate(work)
+
+ end subroutine get_global
+
+! -----------------------------------
+
+! sorting routines put in same file to allow for inlining
+
+ subroutine rank(A,IND,N)
+!
+! Use Heap Sort (Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(n)
+ integer IND(n)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do j=1,n
+ IND(j)=j
+ enddo
+
+ if (n == 1) return
+
+ L=n/2+1
+ ir=n
+ 100 CONTINUE
+ IF (l>1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 CONTINUE
+ IF (J <= IR) THEN
+ IF (J<IR) THEN
+ IF ( A(IND(j))<A(IND(j+1)) ) j=j+1
+ ENDIF
+ IF (q<A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ goto 200
+ ENDIF
+ IND(I)=INDX
+ goto 100
+ end subroutine rank
+
+! ------------------------------------------------------------------
+
+ subroutine swap_all(IA,A,B,C,IW,W,ind,n)
+!
+! swap arrays IA, A, B and C according to addressing in array IND
+!
+ implicit none
+
+ integer n
+
+ integer IND(n)
+ integer IA(n),IW(n)
+ double precision A(n),B(n),C(n),W(n)
+
+ integer i
+
+ IW(:) = IA(:)
+ W(:) = A(:)
+
+ do i=1,n
+ IA(i)=IW(ind(i))
+ A(i)=W(ind(i))
+ enddo
+
+ W(:) = B(:)
+
+ do i=1,n
+ B(i)=W(ind(i))
+ enddo
+
+ W(:) = C(:)
+
+ do i=1,n
+ C(i)=W(ind(i))
+ enddo
+
+ end subroutine swap_all
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_jacobian_boundaries.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_jacobian_boundaries.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_jacobian_boundaries.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_jacobian_boundaries.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,541 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 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)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer NSPEC2D_BOTTOM,NSPEC2D_TOP,NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
+
+ 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 ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP)
+
+ logical iboun(6,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ real(kind=CUSTOM_REAL) 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)
+
+ 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)
+
+! global element numbering
+ integer ispec
+
+! counters to keep track of number of elements on each of the boundaries
+ integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5,ispecb6
+
+ double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes')
+ if(NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes')
+
+ ispecb1 = 0
+ ispecb2 = 0
+ ispecb3 = 0
+ ispecb4 = 0
+ ispecb5 = 0
+ ispecb6 = 0
+
+ do ispec=1,nspec
+
+! determine if the element falls on a boundary
+
+! on boundary: xmin
+
+ if(iboun(1,ispec)) then
+
+ ispecb1=ispecb1+1
+ ibelm_xmin(ispecb1)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(1,1,1,ispec)
+ yelm(1)=ystore(1,1,1,ispec)
+ zelm(1)=zstore(1,1,1,ispec)
+ xelm(2)=xstore(1,NGLLY,1,ispec)
+ yelm(2)=ystore(1,NGLLY,1,ispec)
+ zelm(2)=zstore(1,NGLLY,1,ispec)
+ xelm(3)=xstore(1,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(1,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(1,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(1,1,NGLLZ,ispec)
+ yelm(4)=ystore(1,1,NGLLZ,ispec)
+ zelm(4)=zstore(1,1,NGLLZ,ispec)
+ xelm(5)=xstore(1,(NGLLY+1)/2,1,ispec)
+ yelm(5)=ystore(1,(NGLLY+1)/2,1,ispec)
+ zelm(5)=zstore(1,(NGLLY+1)/2,1,ispec)
+ xelm(6)=xstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(7)=ystore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(7)=zstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(8)=xstore(1,1,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(1,1,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(1,1,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb1,xelm,yelm,zelm,dershape2D_x, &
+ jacobian2D_xmin,normal_xmin,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb1,xstore,ystore,zstore,ibelm_xmin,normal_xmin,&
+ jacobian2D_xmin,NSPEC2DMAX_XMIN_XMAX,NGLLY,NGLLZ,nspec)
+ endif
+ endif
+
+! on boundary: xmax
+
+ if(iboun(2,ispec)) then
+
+ ispecb2=ispecb2+1
+ ibelm_xmax(ispecb2)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(NGLLX,1,1,ispec)
+ yelm(1)=ystore(NGLLX,1,1,ispec)
+ zelm(1)=zstore(NGLLX,1,1,ispec)
+ xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
+ yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
+ zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(NGLLX,1,NGLLZ,ispec)
+ yelm(4)=ystore(NGLLX,1,NGLLZ,ispec)
+ zelm(4)=zstore(NGLLX,1,NGLLZ,ispec)
+ xelm(5)=xstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ yelm(5)=ystore(NGLLX,(NGLLY+1)/2,1,ispec)
+ zelm(5)=zstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ xelm(6)=xstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(7)=ystore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(7)=zstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(8)=xstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb2,xelm,yelm,zelm,dershape2D_x, &
+ jacobian2D_xmax,normal_xmax,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb2,xstore,ystore,zstore,ibelm_xmax,normal_xmax,&
+ jacobian2D_xmax,NSPEC2DMAX_XMIN_XMAX,NGLLY,NGLLZ,nspec)
+ endif
+ endif
+
+! on boundary: ymin
+
+ if(iboun(3,ispec)) then
+
+ ispecb3=ispecb3+1
+ ibelm_ymin(ispecb3)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(1,1,1,ispec)
+ yelm(1)=ystore(1,1,1,ispec)
+ zelm(1)=zstore(1,1,1,ispec)
+ xelm(2)=xstore(NGLLX,1,1,ispec)
+ yelm(2)=ystore(NGLLX,1,1,ispec)
+ zelm(2)=zstore(NGLLX,1,1,ispec)
+ xelm(3)=xstore(NGLLX,1,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,1,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,1,NGLLZ,ispec)
+ xelm(4)=xstore(1,1,NGLLZ,ispec)
+ yelm(4)=ystore(1,1,NGLLZ,ispec)
+ zelm(4)=zstore(1,1,NGLLZ,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,1,1,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,1,1,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,1,1,ispec)
+ xelm(6)=xstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,1,NGLLZ,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ xelm(8)=xstore(1,1,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(1,1,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(1,1,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb3,xelm,yelm,zelm,dershape2D_y, &
+ jacobian2D_ymin,normal_ymin,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb3,xstore,ystore,zstore,ibelm_ymin,normal_ymin,&
+ jacobian2D_ymin,NSPEC2DMAX_YMIN_YMAX,NGLLX,NGLLZ,nspec)
+ endif
+ endif
+
+! on boundary: ymax
+
+ if(iboun(4,ispec)) then
+
+ ispecb4=ispecb4+1
+ ibelm_ymax(ispecb4)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(1,NGLLY,1,ispec)
+ yelm(1)=ystore(1,NGLLY,1,ispec)
+ zelm(1)=zstore(1,NGLLY,1,ispec)
+ xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
+ yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
+ zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
+ yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
+ zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,NGLLY,1,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,NGLLY,1,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,NGLLY,1,ispec)
+ xelm(6)=xstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ xelm(8)=xstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb4,xelm,yelm,zelm,dershape2D_y, &
+ jacobian2D_ymax,normal_ymax,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb4,xstore,ystore,zstore,ibelm_ymax,normal_ymax,&
+ jacobian2D_ymax,NSPEC2DMAX_YMIN_YMAX,NGLLX,NGLLZ,nspec)
+ endif
+ endif
+
+! on boundary: bottom
+
+ if(iboun(5,ispec)) then
+
+ ispecb5=ispecb5+1
+ ibelm_bottom(ispecb5)=ispec
+
+ xelm(1)=xstore(1,1,1,ispec)
+ yelm(1)=ystore(1,1,1,ispec)
+ zelm(1)=zstore(1,1,1,ispec)
+ xelm(2)=xstore(NGLLX,1,1,ispec)
+ yelm(2)=ystore(NGLLX,1,1,ispec)
+ zelm(2)=zstore(NGLLX,1,1,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,1,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,1,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,1,ispec)
+ xelm(4)=xstore(1,NGLLY,1,ispec)
+ yelm(4)=ystore(1,NGLLY,1,ispec)
+ zelm(4)=zstore(1,NGLLY,1,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,1,1,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,1,1,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,1,1,ispec)
+ xelm(6)=xstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ yelm(6)=ystore(NGLLX,(NGLLY+1)/2,1,ispec)
+ zelm(6)=zstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,NGLLY,1,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,NGLLY,1,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,NGLLY,1,ispec)
+ xelm(8)=xstore(1,(NGLLY+1)/2,1,ispec)
+ yelm(8)=ystore(1,(NGLLY+1)/2,1,ispec)
+ zelm(8)=zstore(1,(NGLLY+1)/2,1,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb5,xelm,yelm,zelm,dershape2D_bottom, &
+ jacobian2D_bottom,normal_bottom,NGLLX,NGLLY,NSPEC2D_BOTTOM)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb5,xstore,ystore,zstore,ibelm_bottom,normal_bottom,&
+ jacobian2D_bottom,NSPEC2D_BOTTOM,NGLLX,NGLLY,nspec)
+ endif
+ endif
+
+! on boundary: top
+
+ if(iboun(6,ispec)) then
+
+ ispecb6=ispecb6+1
+ ibelm_top(ispecb6)=ispec
+
+ xelm(1)=xstore(1,1,NGLLZ,ispec)
+ yelm(1)=ystore(1,1,NGLLZ,ispec)
+ zelm(1)=zstore(1,1,NGLLZ,ispec)
+ xelm(2)=xstore(NGLLX,1,NGLLZ,ispec)
+ yelm(2)=ystore(NGLLX,1,NGLLZ,ispec)
+ zelm(2)=zstore(NGLLX,1,NGLLZ,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
+ yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
+ zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,1,NGLLZ,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ xelm(6)=xstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(6)=ystore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(6)=zstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ xelm(8)=xstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(8)=ystore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(8)=zstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb6,xelm,yelm,zelm,dershape2D_top, &
+ jacobian2D_top,normal_top,NGLLX,NGLLY,NSPEC2D_TOP)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb6,xstore,ystore,zstore,ibelm_top,normal_top,&
+ jacobian2D_top,NSPEC2D_TOP,NGLLX,NGLLY,nspec)
+ endif
+ endif
+
+ enddo
+
+
+! check theoretical value of elements at the bottom
+ if(ispecb5 /= NSPEC2D_BOTTOM) then
+ call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM')
+ endif
+
+! check theoretical value of elements at the top
+ if(ispecb6 /= NSPEC2D_TOP) call exit_MPI(myrank,'ispecb6 should equal NSPEC2D_TOP')
+
+ nspec2D_xmin = ispecb1
+ nspec2D_xmax = ispecb2
+ nspec2D_ymin = ispecb3
+ nspec2D_ymax = ispecb4
+
+ end subroutine get_jacobian_boundaries
+
+! -------------------------------------------------------
+
+ subroutine compute_jacobian_2D(myrank,ispecb,xelm,yelm,zelm,dershape2D,jacobian2D,normal,NGLLA,NGLLB,NSPEC2DMAX_AB)
+
+ implicit none
+
+ include "constants.h"
+
+! generic routine that accepts any polynomial degree in each direction
+
+ integer ispecb,NGLLA,NGLLB,NSPEC2DMAX_AB,myrank
+
+ double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
+ double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
+
+ real(kind=CUSTOM_REAL) jacobian2D(NGLLA,NGLLB,NSPEC2DMAX_AB)
+ real(kind=CUSTOM_REAL) normal(3,NGLLA,NGLLB,NSPEC2DMAX_AB)
+
+ integer i,j,ia
+ double precision xxi,xeta,yxi,yeta,zxi,zeta
+ double precision unx,uny,unz,jacobian
+
+ do j=1,NGLLB
+ do i=1,NGLLA
+
+ xxi=ZERO
+ xeta=ZERO
+ yxi=ZERO
+ yeta=ZERO
+ zxi=ZERO
+ zeta=ZERO
+ do ia=1,NGNOD2D
+ xxi=xxi+dershape2D(1,ia,i,j)*xelm(ia)
+ xeta=xeta+dershape2D(2,ia,i,j)*xelm(ia)
+ yxi=yxi+dershape2D(1,ia,i,j)*yelm(ia)
+ yeta=yeta+dershape2D(2,ia,i,j)*yelm(ia)
+ zxi=zxi+dershape2D(1,ia,i,j)*zelm(ia)
+ zeta=zeta+dershape2D(2,ia,i,j)*zelm(ia)
+ enddo
+
+! calculate the unnormalized normal to the boundary
+ unx=yxi*zeta-yeta*zxi
+ uny=zxi*xeta-zeta*xxi
+ unz=xxi*yeta-xeta*yxi
+ jacobian=dsqrt(unx**2+uny**2+unz**2)
+ if(jacobian == ZERO) call exit_MPI(myrank,'2D Jacobian undefined')
+
+! normalize normal vector and store surface jacobian
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ jacobian2D(i,j,ispecb)=sngl(jacobian)
+ normal(1,i,j,ispecb)=sngl(unx/jacobian)
+ normal(2,i,j,ispecb)=sngl(uny/jacobian)
+ normal(3,i,j,ispecb)=sngl(unz/jacobian)
+ else
+ jacobian2D(i,j,ispecb)=jacobian
+ normal(1,i,j,ispecb)=unx/jacobian
+ normal(2,i,j,ispecb)=uny/jacobian
+ normal(3,i,j,ispecb)=unz/jacobian
+ endif
+
+ enddo
+ enddo
+
+ end subroutine compute_jacobian_2D
+
+
+
+subroutine sort_arrays_for_cuthill (ispecb,xstore,ystore,zstore,ibelm,normal,jacobian2D,nspec2D,NGLL1,NGLL2,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: ispecb,nspec2D,NGLL1,NGLL2,nspec,ispec_tmp,dummy_var,i
+
+ integer ibelm(nspec2D)
+ real(kind=CUSTOM_REAL) jacobian2D(NGLL1,NGLL2,NSPEC2D)
+ real(kind=CUSTOM_REAL) normal(NDIM,NGLL1,NGLL2,NSPEC2D)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+ integer, dimension(:), allocatable :: perm
+ integer, dimension(:), allocatable :: ibelm_tmp
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_tmp
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_tmp
+
+! get permutation
+ allocate (xstore_selected(ispecb))
+ allocate (ystore_selected(ispecb))
+ allocate (zstore_selected(ispecb))
+ allocate(ind(ispecb))
+ allocate(ninseg(ispecb))
+ allocate(iglob(ispecb))
+ allocate(locval(ispecb))
+ allocate(ifseg(ispecb))
+ allocate(iwork(ispecb))
+ allocate(work(ispecb))
+ allocate(perm(ispecb))
+
+ do ispec_tmp=1,ispecb
+ xstore_selected(ispec_tmp) = xstore(1,1,1,ibelm(ispec_tmp))
+ ystore_selected(ispec_tmp) = ystore(1,1,1,ibelm(ispec_tmp))
+ zstore_selected(ispec_tmp) = zstore(1,1,1,ibelm(ispec_tmp))
+ perm(ispec_tmp) = ispec_tmp
+ enddo
+
+ call sort_array_coordinates(ispecb,xstore_selected,ystore_selected,zstore_selected, &
+ perm,iglob,locval,ifseg,dummy_var,ind,ninseg,iwork,work)
+
+ deallocate (xstore_selected)
+ deallocate (ystore_selected)
+ deallocate (zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+
+! permutation of ibelm
+ allocate(ibelm_tmp(ispecb))
+ ibelm_tmp(1:ispecb) = ibelm(1:ispecb)
+ do i = 1,ispecb
+ ibelm(perm(i)) = ibelm_tmp(i)
+ enddo
+ deallocate(ibelm_tmp)
+
+! permutation of normal
+ allocate(normal_tmp(NDIM,NGLL1,NGLL2,ispecb))
+ normal_tmp(:,:,:,1:ispecb) = normal(:,:,:,1:ispecb)
+ do i = 1,ispecb
+ normal(:,:,:,perm(i)) = normal_tmp(:,:,:,i)
+ enddo
+ deallocate(normal_tmp)
+
+! permutation of jacobian2D
+ allocate(jacobian2D_tmp(NGLL1,NGLL2,ispecb))
+ jacobian2D_tmp(:,:,1:ispecb) = jacobian2D(:,:,1:ispecb)
+ do i = 1,ispecb
+ jacobian2D(:,:,perm(i)) = jacobian2D_tmp(:,:,i)
+ enddo
+ deallocate(jacobian2D_tmp)
+ deallocate(perm)
+
+end subroutine sort_arrays_for_cuthill
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_model.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_model.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,997 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_model(myrank,iregion_code,nspec, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,rhostore_local, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ nspec_ani, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ xelm,yelm,zelm,shape3D,ispec, &
+ rmin,rmax,idoubling, &
+ rho_vp,rho_vs,nspec_stacey, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE, &
+ CRUSTAL,ONE_CRUST,ATTENUATION,ATTENUATION_3D,tau_s,tau_e_store,Qmu_store,T_c_source,vx,vy,vz,vnspec, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,&
+ 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)
+
+ implicit none
+
+ include "constants.h"
+
+!! DK DK for the merged version
+! include values created by the mesher
+ include "OUTPUT_FILES/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(:), pointer :: 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
+
+! 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
+
+ integer ispec,nspec,idoubling,iregion_code,myrank,nspec_stacey
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ logical ATTENUATION,ATTENUATION_3D,ABSORBING_CONDITIONS
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST
+
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision rmin,rmax,RCMB,RICB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+ real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) kappahstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) muhstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec)
+
+!! DK DK added this for the merged version
+ real(kind=CUSTOM_REAL) kappavstore_local(NGLLX,NGLLY,NGLLZ)
+
+!! DK DK changed this for merged version
+ real(kind=CUSTOM_REAL) rhostore_local(NGLLX,NGLLY,NGLLZ)
+
+ real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey),rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
+
+ integer nspec_ani
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33, &
+ c34,c35,c36,c44,c45,c46,c55,c56,c66
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store, &
+ c33store,c34store,c35store,c36store, &
+ c44store,c45store,c46store,c55store,c56store,c66store
+
+ double precision xmesh,ymesh,zmesh
+
+ integer i,j,k,ia
+ double precision rho,drhodr,vp,vs,Qkappa,Qmu
+ double precision vpv,vph,vsv,vsh,eta_aniso
+ double precision dvp,dvs,drho
+ real(kind=4) xcolat,xlon,xrad,dvpv,dvph,dvsv,dvsh
+ double precision xstore(NGLLX,NGLLY,NGLLZ)
+ double precision ystore(NGLLX,NGLLY,NGLLZ)
+ double precision zstore(NGLLX,NGLLY,NGLLZ)
+ double precision r,r_prem,r_moho,r_dummy,theta,phi
+ double precision lat,lon
+ double precision vpc,vsc,rhoc,moho
+
+! attenuation values
+ integer vx, vy, vz, vnspec
+ double precision, dimension(N_SLS) :: tau_s, tau_e
+ double precision, dimension(vx, vy, vz, vnspec) :: Qmu_store
+ double precision, dimension(N_SLS, vx, vy, vz, vnspec) :: tau_e_store
+ double precision T_c_source
+
+ logical found_crust
+
+ 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)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+ do ia=1,NGNOD
+ xmesh = xmesh + shape3D(ia,i,j,k)*xelm(ia)
+ ymesh = ymesh + shape3D(ia,i,j,k)*yelm(ia)
+ zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
+ enddo
+ r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
+
+ xstore(i,j,k) = xmesh
+ ystore(i,j,k) = ymesh
+ zstore(i,j,k) = zmesh
+
+! make sure we are within the right shell in PREM to honor discontinuities
+! use small geometrical tolerance
+ r_prem = r
+ if(r <= rmin*1.000001d0) r_prem = rmin*1.000001d0
+ if(r >= rmax*0.999999d0) r_prem = rmax*0.999999d0
+
+! get the anisotropic PREM parameters
+ if(TRANSVERSE_ISOTROPY) then
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ call prem_aniso(myrank,r_prem,rho,vpv,vph,vsv,vsh,eta_aniso, &
+ Qkappa,Qmu,idoubling,CRUSTAL,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call model_ref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
+
+ else
+ stop 'unknown 1D transversely isotropic reference Earth model in get_model'
+ endif
+
+ else
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+ call model_iasp91(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
+ ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ call prem_iso(myrank,r_prem,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, &
+ ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ call model_1066a(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ call model_ak135(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call model_ref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
+ if(.not. ISOTROPIC_3D_MANTLE) then
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+ endif
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+ call model_jp1d(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
+ .true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ eta_aniso = 1.d0
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ call model_sea1d(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ eta_aniso = 1.d0
+ else
+ stop 'unknown 1D reference Earth model in get_model'
+ endif
+
+ ! in the case of s362iso we want to save the anisotropic constants for the Voight average
+ if(.not. (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF .and. ISOTROPIC_3D_MANTLE)) then
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ eta_aniso = 1.d0
+ endif
+ endif
+
+! get the 3-D model parameters
+ if(ISOTROPIC_3D_MANTLE) then
+ if(r_prem > RCMB/R_EARTH .and. r_prem < RMOHO/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
+! s20rts
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call mantle_model(r,theta,phi,dvs,dvp,drho,D3MM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
+! sea99 + jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+! use Lebedev model as background and add vp & vs perturbation from Zhao 1994 model
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ if(r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call iso3d_dpzhao_model(r,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
+! sea99
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+! jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ if(r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call iso3d_dpzhao_model(r,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ 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
+! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ dvpv = 0.
+ dvph = 0.
+ dvsv = 0.
+ dvsh = 0.
+ xcolat = sngl(theta*180.0d0/PI)
+ xlon = sngl(phi*180.0d0/PI)
+ xrad = sngl(r*R_EARTH_KM)
+ call subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
+ 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)
+ if(TRANSVERSE_ISOTROPY) then
+ vpv=vpv*(1.0d0+dble(dvpv))
+ vph=vph*(1.0d0+dble(dvph))
+ vsv=vsv*(1.0d0+dble(dvsv))
+ vsh=vsh*(1.0d0+dble(dvsh))
+ else
+ vpv=vpv+dvpv
+ vph=vph+dvph
+ vsv=vsv+dvsv
+ vsh=vsh+dvsh
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vpv=vp
+ vph=vp
+ vsv=vs
+ vsh=vs
+ eta_aniso=1.0d0
+ endif
+ else
+ stop 'unknown 3D Earth model in get_model'
+ endif
+
+! extend 3-D mantle model above the Moho to the surface before adding the crust
+ else if(r_prem >= RMOHO/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ r_moho = 0.999999d0*RMOHO/R_EARTH
+ if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
+! s20rts
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call mantle_model(r_moho,theta,phi,dvs,dvp,drho,D3MM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
+! sea99 + jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r_moho,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+! use Lebedev's model as background and add vp & vs perturbation from Zhao's 1994 model
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ call iso3d_dpzhao_model(r_moho,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
+! sea99
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r_moho,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+! jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ call iso3d_dpzhao_model(r_moho,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ 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
+! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ dvpv = 0.
+ dvph = 0.
+ dvsv = 0.
+ dvsh = 0.
+ xcolat = sngl(theta*180.0d0/PI)
+ xlon = sngl(phi*180.0d0/PI)
+ xrad = sngl(r_moho*R_EARTH_KM)
+ call subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
+ 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)
+ if(TRANSVERSE_ISOTROPY) then
+ vpv=vpv*(1.0d0+dble(dvpv))
+ vph=vph*(1.0d0+dble(dvph))
+ vsv=vsv*(1.0d0+dble(dvsv))
+ vsh=vsh*(1.0d0+dble(dvsh))
+ else
+ vpv=vpv+dvpv
+ vph=vph+dvph
+ vsv=vsv+dvsv
+ vsh=vsh+dvsh
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vpv=vp
+ vph=vp
+ vsv=vs
+ vsh=vs
+ eta_aniso=1.0d0
+ endif
+ else
+ stop 'unknown 3D Earth model in get_model'
+ endif
+
+ endif
+ endif
+
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) &
+ call aniso_inner_core_model(r_prem,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL)
+
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+
+! anisotropic model between the Moho and 670 km (change to CMB if desired)
+ if(r_prem < RMOHO/R_EARTH .and. r_prem > R670/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ call aniso_mantle_model(r_prem,theta,phi,rho,c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,AMM_V)
+! extend 3-D mantle model above the Moho to the surface before adding the crust
+ elseif(r_prem >= RMOHO/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ r_moho = RMOHO/R_EARTH
+ call aniso_mantle_model(r_moho,theta,phi,rho,c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,AMM_V)
+! fill the rest of the mantle with the isotropic model
+ else
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+
+! This is here to identify how and where to include 3D attenuation
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ tau_e(:) = 0.0d0
+ ! Get the value of Qmu (Attenuation) dependedent on
+ ! the radius (r_prem) and idoubling flag
+ call attenuation_model_1D_PREM(r_prem, Qmu, idoubling)
+ ! Get tau_e from tau_s and Qmu
+ call attenuation_conversion(Qmu, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
+ endif
+
+! get the 3-D crustal model
+ if(CRUSTAL) then
+ if(r > R_DEEPEST_CRUST) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+
+ if(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D .or. THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ if(r > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call iso3d_dpzhao_model(r,theta,phi,vpc,vsc,dvp,dvs,rhoc,found_crust,JP3DM_V)
+ if(found_crust) then
+ vpv=vpc
+ vph=vpc
+ vsv=vsc
+ vsh=vsc
+! rho=rhoc
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+ endif
+ else
+ lat=(PI/2.0d0-theta)*180.0d0/PI
+ lon=phi*180.0d0/PI
+ if(lon>180.0d0) lon=lon-360.0d0
+ call crustal_model(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V)
+ if (found_crust) then
+ vpv=vpc
+ vph=vpc
+ vsv=vsc
+ vsh=vsc
+ rho=rhoc
+ eta_aniso=1.0d0
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+ endif
+ else
+ lat=(PI/2.0d0-theta)*180.0d0/PI
+ lon=phi*180.0d0/PI
+ if(lon>180.0d0) lon=lon-360.0d0
+ call crustal_model(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V)
+ if (found_crust) then
+ vpv=vpc
+ vph=vpc
+ vsv=vsc
+ vsh=vsc
+ rho=rhoc
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+ endif
+ endif
+ endif
+
+! define elastic parameters in the model
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+!! DK DK changed this for merged version
+ rhostore_local(i,j,k) = sngl(rho)
+
+!! DK DK added this for merged version
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ kappavstore(i,j,k,ispec) = sngl(rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0))
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) &
+ kappahstore(i,j,k,ispec) = sngl(rho*(vph*vph - 4.d0*vsh*vsh/3.d0))
+ muvstore(i,j,k,ispec) = sngl(rho*vsv*vsv)
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) muhstore(i,j,k,ispec) = sngl(rho*vsh*vsh)
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) eta_anisostore(i,j,k,ispec) = sngl(eta_aniso)
+ else
+!! DK DK added this for merged version
+ kappavstore_local(i,j,k) = sngl(rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0))
+ endif
+
+ if(ABSORBING_CONDITIONS) then
+
+ if(iregion_code == IREGION_OUTER_CORE) then
+
+! we need just vp in the outer core for Stacey conditions
+ rho_vp(i,j,k,ispec) = sngl(vph)
+ rho_vs(i,j,k,ispec) = sngl(0.d0)
+ else
+
+ rho_vp(i,j,k,ispec) = sngl(rho*vph)
+ rho_vs(i,j,k,ispec) = sngl(rho*vsh)
+ endif
+ endif
+
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
+
+ c11store(i,j,k,ispec) = sngl(c11)
+ c33store(i,j,k,ispec) = sngl(c33)
+ c12store(i,j,k,ispec) = sngl(c12)
+ c13store(i,j,k,ispec) = sngl(c13)
+ c44store(i,j,k,ispec) = sngl(c44)
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+
+ c11store(i,j,k,ispec) = sngl(c11)
+ c12store(i,j,k,ispec) = sngl(c12)
+ c13store(i,j,k,ispec) = sngl(c13)
+ c14store(i,j,k,ispec) = sngl(c14)
+ c15store(i,j,k,ispec) = sngl(c15)
+ c16store(i,j,k,ispec) = sngl(c16)
+ c22store(i,j,k,ispec) = sngl(c22)
+ c23store(i,j,k,ispec) = sngl(c23)
+ c24store(i,j,k,ispec) = sngl(c24)
+ c25store(i,j,k,ispec) = sngl(c25)
+ c26store(i,j,k,ispec) = sngl(c26)
+ c33store(i,j,k,ispec) = sngl(c33)
+ c34store(i,j,k,ispec) = sngl(c34)
+ c35store(i,j,k,ispec) = sngl(c35)
+ c36store(i,j,k,ispec) = sngl(c36)
+ c44store(i,j,k,ispec) = sngl(c44)
+ c45store(i,j,k,ispec) = sngl(c45)
+ c46store(i,j,k,ispec) = sngl(c46)
+ c55store(i,j,k,ispec) = sngl(c55)
+ c56store(i,j,k,ispec) = sngl(c56)
+ c66store(i,j,k,ispec) = sngl(c66)
+ endif
+
+ else
+
+!! DK DK changed this for merged version
+ rhostore_local(i,j,k) = rho
+
+!! DK DK added this for merged version
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ kappavstore(i,j,k,ispec) = rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0)
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) &
+ kappahstore(i,j,k,ispec) = rho*(vph*vph - 4.d0*vsh*vsh/3.d0)
+ muvstore(i,j,k,ispec) = rho*vsv*vsv
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) muhstore(i,j,k,ispec) = rho*vsh*vsh
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) eta_anisostore(i,j,k,ispec) = eta_aniso
+ else
+!! DK DK added this for merged version
+ kappavstore_local(i,j,k) = rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0)
+ endif
+
+ if(ABSORBING_CONDITIONS) then
+ if(iregion_code == IREGION_OUTER_CORE) then
+! we need just vp in the outer core for Stacey conditions
+ rho_vp(i,j,k,ispec) = vph
+ rho_vs(i,j,k,ispec) = 0.d0
+ else
+ rho_vp(i,j,k,ispec) = rho*vph
+ rho_vs(i,j,k,ispec) = rho*vsh
+ endif
+ endif
+
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
+ c11store(i,j,k,ispec) = c11
+ c33store(i,j,k,ispec) = c33
+ c12store(i,j,k,ispec) = c12
+ c13store(i,j,k,ispec) = c13
+ c44store(i,j,k,ispec) = c44
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11store(i,j,k,ispec) = c11
+ c12store(i,j,k,ispec) = c12
+ c13store(i,j,k,ispec) = c13
+ c14store(i,j,k,ispec) = c14
+ c15store(i,j,k,ispec) = c15
+ c16store(i,j,k,ispec) = c16
+ c22store(i,j,k,ispec) = c22
+ c23store(i,j,k,ispec) = c23
+ c24store(i,j,k,ispec) = c24
+ c25store(i,j,k,ispec) = c25
+ c26store(i,j,k,ispec) = c26
+ c33store(i,j,k,ispec) = c33
+ c34store(i,j,k,ispec) = c34
+ c35store(i,j,k,ispec) = c35
+ c36store(i,j,k,ispec) = c36
+ c44store(i,j,k,ispec) = c44
+ c45store(i,j,k,ispec) = c45
+ c46store(i,j,k,ispec) = c46
+ c55store(i,j,k,ispec) = c55
+ c56store(i,j,k,ispec) = c56
+ c66store(i,j,k,ispec) = c66
+ endif
+
+ endif
+
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ tau_e_store(:,i,j,k,ispec) = tau_e(:)
+ Qmu_store(i,j,k,ispec) = Qmu
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine get_model
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_perm_cuthill_mckee.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_perm_cuthill_mckee.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_perm_cuthill_mckee.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_perm_cuthill_mckee.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,804 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! implement reverse Cuthill-McKee (1969) ordering, introduced in
+! E. Cuthill and J. McKee. Reducing the bandwidth of sparse symmetric matrices.
+! In Proceedings of the 1969 24th national conference, pages 157-172,
+! New-York, New-York, USA, 1969. ACM Press.
+! see for instance http://en.wikipedia.org/wiki/Cuthill%E2%80%93McKee_algorithm
+
+ subroutine get_perm(ibool,perm,limit,nspec,nglob,INVERSE,FACE)
+
+ implicit none
+
+ include "constants.h"
+
+ logical :: INVERSE,FACE
+
+! input
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! output
+ integer, dimension(nspec) :: perm
+
+! local variables
+ integer nspec,nglob_GLL_full
+
+! a neighbor of a hexahedral node is a hexahedra which share a face whith it -> max degre of a node = 6
+ integer, parameter :: MAX_NUMBER_OF_NEIGHBORS = 100
+
+! global corner numbers that need to be created
+ integer, dimension(nglob) :: global_corner_number
+
+ integer mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
+ integer, dimension(:), allocatable :: ne,np,adj
+ integer xadj(nspec+1)
+
+! arrays to store the permutation and inverse permutation of the Cuthill-McKee algorithm
+ integer, dimension(nspec) :: invperm
+
+ logical maskel(nspec)
+
+ integer i,istart,istop,number_of_neighbors
+
+ integer nglob_eight_corners_only,nglob
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne,total_size_adj,limit
+
+!
+!-----------------------------------------------------------------------
+!
+ if(PERFORM_CUTHILL_MCKEE) then
+
+ ! total number of points in the mesh
+ nglob_GLL_full = nglob
+
+ !---- call Charbel Farhat's routines
+ call form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,nglob_GLL_full,ibool,nglob_eight_corners_only)
+ do i=1,nspec
+ istart = mp(i)
+ istop = mp(i+1) - 1
+ enddo
+
+ allocate(np(nglob_eight_corners_only+1))
+ count_only = .true.
+ total_size_ne = 1
+ allocate(ne(total_size_ne))
+ call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,nspec,count_only,total_size_ne)
+ deallocate(ne)
+ allocate(ne(total_size_ne))
+ count_only = .false.
+ call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,nspec,count_only,total_size_ne)
+ do i=1,nglob_eight_corners_only
+ istart = np(i)
+ istop = np(i+1) - 1
+ enddo
+
+ count_only = .true.
+ total_size_adj = 1
+ allocate(adj(total_size_adj))
+ call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,&
+ count_only,total_size_ne,total_size_adj,FACE)
+ deallocate(adj)
+ allocate(adj(total_size_adj))
+ count_only = .false.
+ call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,&
+ count_only,total_size_ne,total_size_adj,FACE)
+ do i=1,nspec
+ istart = xadj(i)
+ istop = xadj(i+1) - 1
+ number_of_neighbors = istop-istart+1
+ if(number_of_neighbors < 1 .or. number_of_neighbors > MAX_NUMBER_OF_NEIGHBORS) stop 'incorrect number of neighbors'
+ enddo
+ deallocate(ne,np)
+
+! call the Cuthill-McKee sorting algorithm
+ call cuthill_mckee(adj,xadj,perm,invperm,nspec,total_size_adj,limit,INVERSE)
+ deallocate(adj)
+ else
+! create identity permutation in order to do nothing
+ do i=1,nspec
+ perm(i) = i
+ enddo
+ endif
+
+ end subroutine get_perm
+
+!=======================================================================
+!
+! Charbel Farhat's FEM topology routines
+!
+! Dimitri Komatitsch, February 1996 - Code based on Farhat's original version
+! described in his technical report from 1987
+!
+! modified and adapted by Dimitri Komatitsch, May 2006
+!
+!=======================================================================
+
+ subroutine form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number, &
+ nglob_GLL_full,ibool,nglob_eight_corners_only)
+
+!-----------------------------------------------------------------------
+!
+! Forms the MN and MP arrays
+!
+! Input :
+! -------
+! ibool Array needed to build the element connectivity table
+! nspec Number of elements in the domain
+! NGNOD_HEXAHEDRA number of nodes per hexahedron (brick with 8 corners)
+!
+! Output :
+! --------
+! MN, MP This is the element connectivity array pair.
+! Array MN contains the list of the element
+! connectivity, that is, the nodes contained in each
+! element. They are stored in a stacked fashion.
+!
+! Pointer array MP stores the location of each
+! element list. Its length is equal to the number
+! of elements plus one.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,nglob_GLL_full
+
+! arrays with mesh parameters per slice
+ integer, intent(in), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! global corner numbers that need to be created
+ integer, intent(out), dimension(nglob_GLL_full) :: global_corner_number
+ integer, intent(out) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
+ integer, intent(out) :: nglob_eight_corners_only
+
+ integer ninter,nsum,ispec,node,k,inumcorner,ix,iy,iz
+
+ ninter = 1
+ nsum = 1
+ mp(1) = 1
+
+!---- define topology of the elements in the mesh
+!---- we need to define adjacent numbers from the sub-mesh consisting of the corners only
+ nglob_eight_corners_only = 0
+ global_corner_number(:) = -1
+
+ do ispec=1,nspec
+
+ inumcorner = 0
+ do iz = 1,NGLLZ,NGLLZ-1
+ do iy = 1,NGLLY,NGLLY-1
+ do ix = 1,NGLLX,NGLLX-1
+
+ inumcorner = inumcorner + 1
+ if(inumcorner > NGNOD_HEXAHEDRA) stop 'corner number too large'
+
+! check if this point was already assigned a number previously, otherwise create one and store it
+ if(global_corner_number(ibool(ix,iy,iz,ispec)) == -1) then
+ nglob_eight_corners_only = nglob_eight_corners_only + 1
+ global_corner_number(ibool(ix,iy,iz,ispec)) = nglob_eight_corners_only
+ endif
+
+ node = global_corner_number(ibool(ix,iy,iz,ispec))
+ do k=nsum,ninter-1
+ if(node == mn(k)) goto 200
+ enddo
+
+ mn(ninter) = node
+ ninter = ninter + 1
+ 200 continue
+
+ enddo
+ enddo
+ enddo
+
+ nsum = ninter
+ mp(ispec + 1) = nsum
+
+ enddo
+
+ end subroutine form_elt_connectivity_foelco
+
+!
+!----------------------------------------------------
+!
+
+ subroutine form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only, &
+ nspec,count_only,total_size_ne)
+
+!-----------------------------------------------------------------------
+!
+! Forms the NE and NP arrays
+!
+! Input :
+! -------
+! MN, MP, nspec
+! nglob_eight_corners_only Number of nodes in the domain
+!
+! Output :
+! --------
+! NE, NP This is the node-connected element array pair.
+! Integer array NE contains a list of the
+! elements connected to each node, stored in stacked fashion.
+!
+! Array NP is the pointer array for the
+! location of a node's element list in the NE array.
+! Its length is equal to the number of points plus one.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne
+
+ integer nglob_eight_corners_only,nspec
+
+ integer, intent(in) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
+
+ integer, intent(out) :: ne(total_size_ne),np(nglob_eight_corners_only+1)
+
+ integer nsum,inode,ispec,j
+
+ nsum = 1
+ np(1) = 1
+
+ do inode=1,nglob_eight_corners_only
+ do 200 ispec=1,nspec
+
+ do j=mp(ispec),mp(ispec + 1) - 1
+ if (mn(j) == inode) then
+ if(count_only) then
+ total_size_ne = nsum
+ else
+ ne(nsum) = ispec
+ endif
+ nsum = nsum + 1
+ goto 200
+ endif
+ enddo
+ 200 continue
+
+ np(inode + 1) = nsum
+
+ enddo
+
+ end subroutine form_node_connectivity_fonoco
+
+!
+!----------------------------------------------------
+!
+
+ subroutine create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec, &
+ nglob_eight_corners_only,count_only,total_size_ne,total_size_adj,face)
+
+!-----------------------------------------------------------------------
+!
+! Establishes the element adjacency information of the mesh
+! Two elements are considered adjacent if they share a face.
+!
+! Input :
+! -------
+! MN, MP, NE, NP, nspec
+! MASKEL logical mask (length = nspec)
+!
+! Output :
+! --------
+! ADJ, XADJ This is the element adjacency array pair. Array
+! ADJ contains the list of the elements adjacent to
+! element i. They are stored in a stacked fashion.
+! Pointer array XADJ stores the location of each element list.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only,face
+ integer total_size_ne,total_size_adj
+
+ integer nglob_eight_corners_only
+
+ integer, intent(in) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1),ne(total_size_ne),np(nglob_eight_corners_only+1)
+
+ integer, intent(out) :: adj(total_size_adj),xadj(nspec+1)
+
+ logical maskel(nspec)
+ integer countel(nspec)
+
+ integer nspec,iad,ispec,istart,istop,ino,node,jstart,jstop,nelem,jel
+
+ xadj(1) = 1
+ iad = 1
+
+ do ispec=1,nspec
+
+! reset mask
+ maskel(:) = .false.
+
+! mask current element
+ maskel(ispec) = .true.
+ if (face) countel(:) = 0
+
+ istart = mp(ispec)
+ istop = mp(ispec+1) - 1
+ do ino=istart,istop
+ node = mn(ino)
+ jstart = np(node)
+ jstop = np(node + 1) - 1
+ do 120 jel=jstart,jstop
+ nelem = ne(jel)
+ if(maskel(nelem)) goto 120
+ if (face) then
+ ! if 2 elements share at least 3 corners, therefore they share a face
+ countel(nelem) = countel(nelem) + 1
+ if (countel(nelem)>=3) then
+ if(count_only) then
+ total_size_adj = iad
+ else
+ adj(iad) = nelem
+ endif
+ maskel(nelem) = .true.
+ iad = iad + 1
+ endif
+ else
+ if(count_only) then
+ total_size_adj = iad
+ else
+ adj(iad) = nelem
+ endif
+ maskel(nelem) = .true.
+ iad = iad + 1
+ endif
+ 120 continue
+ enddo
+
+ xadj(ispec+1) = iad
+
+ enddo
+
+ end subroutine create_adjacency_table_adjncy
+
+!
+!----------------------------------------------------
+!
+
+ subroutine cuthill_mckee(adj,xadj,mask,invperm_all,nspec,total_size_adj,limit,INVERSE)
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: nspec,total_size_adj, limit
+ integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
+
+ integer, intent(out), dimension(nspec) :: mask,invperm_all
+ integer, dimension(nspec) :: invperm_sub
+ logical :: INVERSE
+ integer ispec,gsize,counter,nspec_sub,root,total_ordered_elts, next_root
+
+! fill the mask with ones
+ mask(:) = 1
+ invperm_all(:) = 0
+ counter = 0
+ nspec_sub = limit
+ root = 1
+ total_ordered_elts = 0
+
+ do while(total_ordered_elts < nspec)
+ ! creation of a sublist of sorted elements which fit in the cache (the criterion of size is limit)
+ ! limit = nb of element that can fit in the L2 cache
+ call Cut_McK( root, nspec, total_size_adj, xadj, adj, mask, gsize, invperm_sub, limit, nspec_sub, next_root)
+ ! add the sublist in the main permutation list
+ invperm_all(total_ordered_elts+1:total_ordered_elts+nspec_sub) = invperm_sub(1:nspec_sub)
+ total_ordered_elts = total_ordered_elts + nspec_sub
+ ! seek for a new root to build the new sublist
+ if (next_root > 0) then
+ root = next_root
+ else
+ if (total_ordered_elts /= nspec) &
+ call find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
+ root = next_root
+ endif
+ enddo
+
+ if (INVERSE) then
+ do ispec=1,nspec
+ mask(invperm_all(ispec)) = ispec
+ enddo
+ else
+ mask(:) = invperm_all(:)
+ endif
+
+ end subroutine cuthill_mckee
+
+
+!*******************************************************************************
+! Objective: Cuthill-McKee ordering
+! The algorithm is:
+!
+! X(1) = ROOT.
+! for ( I = 1 to N-1)
+! Find all unlabeled neighbors of X(I),
+! assign them the next available labels, in order of increasing degree.
+!
+! Parameters:
+! root the starting point for the cm ordering.
+! nbnodes the number of nodes.
+! nnz the number of adjacency entries.
+!
+! xadj/adj the graph
+! mask only those nodes with nonzero mask are considered
+!
+! gsize the number of the connected component
+! invp Inverse invputation (from new order to old order)
+!*******************************************************************************
+
+subroutine find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+! input
+ integer, intent(in) :: total_size_adj,total_ordered_elts,nspec
+ integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
+ integer, intent(in), dimension(nspec) :: mask,invperm_all
+! output
+ integer, intent(out) :: next_root
+! variables
+ integer :: cur_node,neighbor_node,i,j
+
+ do i=total_ordered_elts, 1, -1
+ cur_node = invperm_all(i)
+ do j= xadj(cur_node), xadj(cur_node+1)-1
+ neighbor_node = adj(j)
+ if (mask(neighbor_node)/=0) then
+ next_root=neighbor_node
+ return
+ endif
+ enddo
+ enddo
+
+end subroutine find_next_root
+
+!*******************************************************************************
+! Objective: Cuthill-McKee ordering
+! The algorithm is:
+!
+! X(1) = ROOT.
+! for ( I = 1 to N-1)
+! Find all unlabeled neighbors of X(I),
+! assign them the next available labels, in order of increasing degree.
+!
+! Parameters:
+! root the starting point for the cm ordering.
+! nbnodes the number of nodes.
+! nnz the number of adjacency entries.
+!
+! xadj/adj the graph
+! mask only those nodes with nonzero mask are considered
+!
+! gsize the number of the connected component
+! invp Inverse invputation (from new order to old order)
+!*******************************************************************************
+
+subroutine Cut_McK( root, nbnodes, nnz, xadj, adj, mask, gsize, invp, limit, nspec_sub, next_root)
+
+ implicit none
+
+ include "constants.h"
+
+!--------------------------------------------------------------- Input Variables
+ integer root, nnz, nbnodes, limit, nspec_sub, next_root
+
+ integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
+
+!-------------------------------------------------------------- Output Variables
+ integer gsize
+ integer invp(nbnodes)
+
+!--------------------------------------------------------------- Local Variables
+ integer i, j, k, l, lbegin, lnbr, linvp, lvlend, nbr, node, fnbr
+ integer deg(nbnodes)
+
+! Find the degrees of the nodes in the subgraph specified by mask and root
+! Here invp is used to store a levelization of the subgraph
+ invp(:)=0
+ deg(:)=0
+ call degree ( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, invp)
+
+ mask(root) = 0
+
+ IF (gsize > 1) THEN
+ !If there is at least 2 nodes in the subgraph
+ lvlend = 0
+ lnbr = 1
+
+ DO while (lvlend < lnbr)
+ !lbegin/lvlend point to the begin/end of the present level
+ lbegin = lvlend + 1
+ lvlend = lnbr
+
+ do i= lbegin, lvlend
+ node = invp(i)
+
+ !Find the unnumbered neighbours of node.
+ !fnbr/lnbr point to the first/last neighbors of node
+ fnbr = lnbr + 1
+ do j= xadj(node), xadj(node+1)-1
+ nbr = adj(j)
+
+ if (mask(nbr) /= 0) then
+ lnbr = lnbr + 1
+ mask(nbr) = 0
+ invp(lnbr) = nbr
+ endif
+ enddo
+
+ !If no neighbors, go to next node in this level.
+ IF (lnbr > fnbr) THEN
+ !Sort the neighbors of NODE in increasing order by degree.
+ !Linear insertion is used.
+ k = fnbr
+ do while (k < lnbr)
+ l = k
+ k = k + 1
+ nbr = invp(k)
+
+ DO WHILE (fnbr < l)
+ linvp = invp(l)
+
+ if (deg(linvp) <= deg(nbr)) then
+ exit
+ endif
+
+ invp(l+1) = linvp
+ l = l-1
+ ENDDO
+
+ invp(l+1) = nbr
+ enddo
+ ENDIF
+ enddo
+ ENDDO
+
+ ENDIF
+
+ if (gsize > limit) then
+ do i = limit + 1 , nbnodes
+ node=invp(i)
+ if (node /=0) mask(node) = 1
+ enddo
+ next_root = invp(limit +1)
+ nspec_sub = limit
+ else
+ next_root = -1
+ nspec_sub = gsize
+ endif
+
+END subroutine Cut_McK
+
+
+!*******************************************************************************
+! Objective: computes the degrees of the nodes in the connected graph
+!
+! Parameters:
+! root the root node
+! nbnodes the number of nodes in the graph
+! nnz the graph size
+! xadj/adj the whole graph
+! mask Only nodes with mask == 0 are considered
+!
+! gsize the number of nodes in the connected graph
+! deg degree for all the nodes in the connected graph
+! level levelization of the connected graph
+!
+!*******************************************************************************
+
+subroutine degree( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, level )
+
+ implicit none
+
+!--------------------------------------------------------------- Input Variables
+ integer root, nbnodes, nnz
+ integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
+
+!-------------------------------------------------------------- Output Variables
+ integer gsize
+ integer deg(nbnodes), level(nbnodes)
+
+!--------------------------------------------------------------- Local Variables
+ integer i, j, ideg, lbegin, lvlend, lvsize, nxt, nbr, node
+
+! The sign of xadj(I) is used to indicate if node i has been considered
+ xadj(root) = -xadj(root)
+ level(1) = root
+ nxt = 1
+ lvlend = 0
+ lvsize = 1
+
+ DO WHILE (lvsize > 0)
+ ! lbegin/lvlend points the begin/end of the present level
+ lbegin = lvlend + 1
+ lvlend = nxt
+
+ ! Find the degrees of nodes in the present level and generate the next level
+ DO i= lbegin, lvlend
+ node = level(i)
+ ideg = 0
+ do j= ABS( xadj(node) ), ABS( xadj(node+1) )-1
+ nbr = adj(j)
+
+ if (mask(nbr) /= 0) then
+ ideg = ideg + 1
+
+ if (xadj(nbr) >= 0) then
+ xadj(nbr) = -xadj(nbr)
+ nxt = nxt + 1
+ level(nxt) = nbr
+ endif
+ endif
+ enddo
+
+ deg(node) = ideg
+ ENDDO
+
+ !Compute the level size of the next level
+ lvsize = nxt - lvlend
+ ENDDO
+
+ !Reset xadj to its correct sign
+ do i = 1, nxt
+ node = level(i)
+ xadj(node) = -xadj(node)
+ enddo
+
+ gsize = nxt
+
+END subroutine degree
+
+!
+!-----------------------------------------------------------------------
+!
+
+ subroutine permute_elements_real(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ real(kind=CUSTOM_REAL), intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_real
+
+!
+!-----------------------------------------------------------------------
+!
+
+!! DK DK added this for merged version
+ subroutine permute_elements_xelm_yelm_zelm(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ real(kind=CUSTOM_REAL), intent(inout), dimension(NGNOD,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:) = array_to_permute(:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,new_ispec) = temp_array(:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_xelm_yelm_zelm
+
+!
+!-----------------------------------------------------------------------
+!
+
+! implement permutation of elements for arrays of integer type
+ subroutine permute_elements_integer(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ integer, intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_integer
+
+!
+!-----------------------------------------------------------------------
+!
+
+! implement permutation of elements for arrays of double precision type
+ subroutine permute_elements_dble(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ double precision, intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_dble
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_shape2D.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape2D.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_shape2D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_shape2D.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,160 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_shape2D(myrank,shape2D,dershape2D,xigll,yigll,NGLLA,NGLLB)
+
+ implicit none
+
+ include "constants.h"
+
+! generic routine that accepts any polynomial degree in each direction
+
+ integer NGLLA,NGLLB,myrank
+
+ double precision xigll(NGLLA)
+ double precision yigll(NGLLB)
+
+! 2D shape functions and their derivatives
+ double precision shape2D(NGNOD2D,NGLLA,NGLLB)
+ double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
+
+ integer i,j,ia
+
+! location of the nodes of the 2D quadrilateral elements
+ double precision xi,eta
+ double precision l1xi,l2xi,l3xi,l1eta,l2eta,l3eta
+ double precision l1pxi,l2pxi,l3pxi,l1peta,l2peta,l3peta
+
+! for checking the 2D shape functions
+ double precision sumshape,sumdershapexi,sumdershapeeta
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes')
+ if(NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes')
+
+! generate the 2D shape functions and their derivatives (9 nodes)
+ do i=1,NGLLA
+
+ xi=xigll(i)
+
+ l1xi=HALF*xi*(xi-ONE)
+ l2xi=ONE-xi**2
+ l3xi=HALF*xi*(xi+ONE)
+
+ l1pxi=xi-HALF
+ l2pxi=-TWO*xi
+ l3pxi=xi+HALF
+
+ do j=1,NGLLB
+
+ eta=yigll(j)
+
+ l1eta=HALF*eta*(eta-ONE)
+ l2eta=ONE-eta**2
+ l3eta=HALF*eta*(eta+ONE)
+
+ l1peta=eta-HALF
+ l2peta=-TWO*eta
+ l3peta=eta+HALF
+
+! corner nodes
+
+ shape2D(1,i,j)=l1xi*l1eta
+ shape2D(2,i,j)=l3xi*l1eta
+ shape2D(3,i,j)=l3xi*l3eta
+ shape2D(4,i,j)=l1xi*l3eta
+
+ dershape2D(1,1,i,j)=l1pxi*l1eta
+ dershape2D(1,2,i,j)=l3pxi*l1eta
+ dershape2D(1,3,i,j)=l3pxi*l3eta
+ dershape2D(1,4,i,j)=l1pxi*l3eta
+
+ dershape2D(2,1,i,j)=l1xi*l1peta
+ dershape2D(2,2,i,j)=l3xi*l1peta
+ dershape2D(2,3,i,j)=l3xi*l3peta
+ dershape2D(2,4,i,j)=l1xi*l3peta
+
+! midside nodes
+
+ shape2D(5,i,j)=l2xi*l1eta
+ shape2D(6,i,j)=l3xi*l2eta
+ shape2D(7,i,j)=l2xi*l3eta
+ shape2D(8,i,j)=l1xi*l2eta
+
+ dershape2D(1,5,i,j)=l2pxi*l1eta
+ dershape2D(1,6,i,j)=l3pxi*l2eta
+ dershape2D(1,7,i,j)=l2pxi*l3eta
+ dershape2D(1,8,i,j)=l1pxi*l2eta
+
+ dershape2D(2,5,i,j)=l2xi*l1peta
+ dershape2D(2,6,i,j)=l3xi*l2peta
+ dershape2D(2,7,i,j)=l2xi*l3peta
+ dershape2D(2,8,i,j)=l1xi*l2peta
+
+! center node
+
+ shape2D(9,i,j)=l2xi*l2eta
+
+ dershape2D(1,9,i,j)=l2pxi*l2eta
+ dershape2D(2,9,i,j)=l2xi*l2peta
+
+ enddo
+ enddo
+
+! check the 2D shape functions
+ do i=1,NGLLA
+ do j=1,NGLLB
+
+ sumshape=ZERO
+
+ sumdershapexi=ZERO
+ sumdershapeeta=ZERO
+
+ do ia=1,NGNOD2D
+
+ sumshape=sumshape+shape2D(ia,i,j)
+
+ sumdershapexi=sumdershapexi+dershape2D(1,ia,i,j)
+ sumdershapeeta=sumdershapeeta+dershape2D(2,ia,i,j)
+
+ enddo
+
+! the sum of the shape functions should be 1
+ if(abs(sumshape-ONE)>TINYVAL) call exit_MPI(myrank,'error in 2D shape functions')
+
+! the sum of the derivatives of the shape functions should be 0
+ if(abs(sumdershapexi)>TINYVAL) &
+ call exit_MPI(myrank,'error in xi derivatives of 2D shape function')
+
+ if(abs(sumdershapeeta)>TINYVAL) &
+ call exit_MPI(myrank,'error in eta derivatives of 2D shape function')
+
+ enddo
+ enddo
+
+ end subroutine get_shape2D
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_shape3D.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape3D.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_shape3D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_shape3D.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,268 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision yigll(NGLLY)
+ double precision zigll(NGLLZ)
+
+! 3D shape functions and their derivatives
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+ double precision dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ integer i,j,k,ia
+
+! location of the nodes of the 3D quadrilateral elements
+ double precision xi,eta,gamma
+ double precision l1xi,l2xi,l3xi,l1eta,l2eta,l3eta,l1gamma,l2gamma,l3gamma
+ double precision l1pxi,l2pxi,l3pxi,l1peta,l2peta,l3peta,l1pgamma,l2pgamma,l3pgamma
+
+! for checking the 3D shape functions
+ double precision sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes')
+
+! generate the 3D shape functions and their derivatives (27 nodes)
+ do i=1,NGLLX
+
+ xi=xigll(i)
+
+ l1xi=HALF*xi*(xi-ONE)
+ l2xi=ONE-xi**2
+ l3xi=HALF*xi*(xi+ONE)
+
+ l1pxi=xi-HALF
+ l2pxi=-TWO*xi
+ l3pxi=xi+HALF
+
+ do j=1,NGLLY
+
+ eta=yigll(j)
+
+ l1eta=HALF*eta*(eta-ONE)
+ l2eta=ONE-eta**2
+ l3eta=HALF*eta*(eta+ONE)
+
+ l1peta=eta-HALF
+ l2peta=-TWO*eta
+ l3peta=eta+HALF
+
+ do k=1,NGLLZ
+
+ gamma=zigll(k)
+
+ l1gamma=HALF*gamma*(gamma-ONE)
+ l2gamma=ONE-gamma**2
+ l3gamma=HALF*gamma*(gamma+ONE)
+
+ l1pgamma=gamma-HALF
+ l2pgamma=-TWO*gamma
+ l3pgamma=gamma+HALF
+
+! corner nodes
+
+ shape3D(1,i,j,k)=l1xi*l1eta*l1gamma
+ shape3D(2,i,j,k)=l3xi*l1eta*l1gamma
+ shape3D(3,i,j,k)=l3xi*l3eta*l1gamma
+ shape3D(4,i,j,k)=l1xi*l3eta*l1gamma
+ shape3D(5,i,j,k)=l1xi*l1eta*l3gamma
+ shape3D(6,i,j,k)=l3xi*l1eta*l3gamma
+ shape3D(7,i,j,k)=l3xi*l3eta*l3gamma
+ shape3D(8,i,j,k)=l1xi*l3eta*l3gamma
+
+ dershape3D(1,1,i,j,k)=l1pxi*l1eta*l1gamma
+ dershape3D(1,2,i,j,k)=l3pxi*l1eta*l1gamma
+ dershape3D(1,3,i,j,k)=l3pxi*l3eta*l1gamma
+ dershape3D(1,4,i,j,k)=l1pxi*l3eta*l1gamma
+ dershape3D(1,5,i,j,k)=l1pxi*l1eta*l3gamma
+ dershape3D(1,6,i,j,k)=l3pxi*l1eta*l3gamma
+ dershape3D(1,7,i,j,k)=l3pxi*l3eta*l3gamma
+ dershape3D(1,8,i,j,k)=l1pxi*l3eta*l3gamma
+
+ dershape3D(2,1,i,j,k)=l1xi*l1peta*l1gamma
+ dershape3D(2,2,i,j,k)=l3xi*l1peta*l1gamma
+ dershape3D(2,3,i,j,k)=l3xi*l3peta*l1gamma
+ dershape3D(2,4,i,j,k)=l1xi*l3peta*l1gamma
+ dershape3D(2,5,i,j,k)=l1xi*l1peta*l3gamma
+ dershape3D(2,6,i,j,k)=l3xi*l1peta*l3gamma
+ dershape3D(2,7,i,j,k)=l3xi*l3peta*l3gamma
+ dershape3D(2,8,i,j,k)=l1xi*l3peta*l3gamma
+
+ dershape3D(3,1,i,j,k)=l1xi*l1eta*l1pgamma
+ dershape3D(3,2,i,j,k)=l3xi*l1eta*l1pgamma
+ dershape3D(3,3,i,j,k)=l3xi*l3eta*l1pgamma
+ dershape3D(3,4,i,j,k)=l1xi*l3eta*l1pgamma
+ dershape3D(3,5,i,j,k)=l1xi*l1eta*l3pgamma
+ dershape3D(3,6,i,j,k)=l3xi*l1eta*l3pgamma
+ dershape3D(3,7,i,j,k)=l3xi*l3eta*l3pgamma
+ dershape3D(3,8,i,j,k)=l1xi*l3eta*l3pgamma
+
+! midside nodes
+
+ shape3D(9,i,j,k)=l2xi*l1eta*l1gamma
+ shape3D(10,i,j,k)=l3xi*l2eta*l1gamma
+ shape3D(11,i,j,k)=l2xi*l3eta*l1gamma
+ shape3D(12,i,j,k)=l1xi*l2eta*l1gamma
+ shape3D(13,i,j,k)=l1xi*l1eta*l2gamma
+ shape3D(14,i,j,k)=l3xi*l1eta*l2gamma
+ shape3D(15,i,j,k)=l3xi*l3eta*l2gamma
+ shape3D(16,i,j,k)=l1xi*l3eta*l2gamma
+ shape3D(17,i,j,k)=l2xi*l1eta*l3gamma
+ shape3D(18,i,j,k)=l3xi*l2eta*l3gamma
+ shape3D(19,i,j,k)=l2xi*l3eta*l3gamma
+ shape3D(20,i,j,k)=l1xi*l2eta*l3gamma
+
+ dershape3D(1,9,i,j,k)=l2pxi*l1eta*l1gamma
+ dershape3D(1,10,i,j,k)=l3pxi*l2eta*l1gamma
+ dershape3D(1,11,i,j,k)=l2pxi*l3eta*l1gamma
+ dershape3D(1,12,i,j,k)=l1pxi*l2eta*l1gamma
+ dershape3D(1,13,i,j,k)=l1pxi*l1eta*l2gamma
+ dershape3D(1,14,i,j,k)=l3pxi*l1eta*l2gamma
+ dershape3D(1,15,i,j,k)=l3pxi*l3eta*l2gamma
+ dershape3D(1,16,i,j,k)=l1pxi*l3eta*l2gamma
+ dershape3D(1,17,i,j,k)=l2pxi*l1eta*l3gamma
+ dershape3D(1,18,i,j,k)=l3pxi*l2eta*l3gamma
+ dershape3D(1,19,i,j,k)=l2pxi*l3eta*l3gamma
+ dershape3D(1,20,i,j,k)=l1pxi*l2eta*l3gamma
+
+ dershape3D(2,9,i,j,k)=l2xi*l1peta*l1gamma
+ dershape3D(2,10,i,j,k)=l3xi*l2peta*l1gamma
+ dershape3D(2,11,i,j,k)=l2xi*l3peta*l1gamma
+ dershape3D(2,12,i,j,k)=l1xi*l2peta*l1gamma
+ dershape3D(2,13,i,j,k)=l1xi*l1peta*l2gamma
+ dershape3D(2,14,i,j,k)=l3xi*l1peta*l2gamma
+ dershape3D(2,15,i,j,k)=l3xi*l3peta*l2gamma
+ dershape3D(2,16,i,j,k)=l1xi*l3peta*l2gamma
+ dershape3D(2,17,i,j,k)=l2xi*l1peta*l3gamma
+ dershape3D(2,18,i,j,k)=l3xi*l2peta*l3gamma
+ dershape3D(2,19,i,j,k)=l2xi*l3peta*l3gamma
+ dershape3D(2,20,i,j,k)=l1xi*l2peta*l3gamma
+
+ dershape3D(3,9,i,j,k)=l2xi*l1eta*l1pgamma
+ dershape3D(3,10,i,j,k)=l3xi*l2eta*l1pgamma
+ dershape3D(3,11,i,j,k)=l2xi*l3eta*l1pgamma
+ dershape3D(3,12,i,j,k)=l1xi*l2eta*l1pgamma
+ dershape3D(3,13,i,j,k)=l1xi*l1eta*l2pgamma
+ dershape3D(3,14,i,j,k)=l3xi*l1eta*l2pgamma
+ dershape3D(3,15,i,j,k)=l3xi*l3eta*l2pgamma
+ dershape3D(3,16,i,j,k)=l1xi*l3eta*l2pgamma
+ dershape3D(3,17,i,j,k)=l2xi*l1eta*l3pgamma
+ dershape3D(3,18,i,j,k)=l3xi*l2eta*l3pgamma
+ dershape3D(3,19,i,j,k)=l2xi*l3eta*l3pgamma
+ dershape3D(3,20,i,j,k)=l1xi*l2eta*l3pgamma
+
+! side center nodes
+
+ shape3D(21,i,j,k)=l2xi*l2eta*l1gamma
+ shape3D(22,i,j,k)=l2xi*l1eta*l2gamma
+ shape3D(23,i,j,k)=l3xi*l2eta*l2gamma
+ shape3D(24,i,j,k)=l2xi*l3eta*l2gamma
+ shape3D(25,i,j,k)=l1xi*l2eta*l2gamma
+ shape3D(26,i,j,k)=l2xi*l2eta*l3gamma
+
+ dershape3D(1,21,i,j,k)=l2pxi*l2eta*l1gamma
+ dershape3D(1,22,i,j,k)=l2pxi*l1eta*l2gamma
+ dershape3D(1,23,i,j,k)=l3pxi*l2eta*l2gamma
+ dershape3D(1,24,i,j,k)=l2pxi*l3eta*l2gamma
+ dershape3D(1,25,i,j,k)=l1pxi*l2eta*l2gamma
+ dershape3D(1,26,i,j,k)=l2pxi*l2eta*l3gamma
+
+ dershape3D(2,21,i,j,k)=l2xi*l2peta*l1gamma
+ dershape3D(2,22,i,j,k)=l2xi*l1peta*l2gamma
+ dershape3D(2,23,i,j,k)=l3xi*l2peta*l2gamma
+ dershape3D(2,24,i,j,k)=l2xi*l3peta*l2gamma
+ dershape3D(2,25,i,j,k)=l1xi*l2peta*l2gamma
+ dershape3D(2,26,i,j,k)=l2xi*l2peta*l3gamma
+
+ dershape3D(3,21,i,j,k)=l2xi*l2eta*l1pgamma
+ dershape3D(3,22,i,j,k)=l2xi*l1eta*l2pgamma
+ dershape3D(3,23,i,j,k)=l3xi*l2eta*l2pgamma
+ dershape3D(3,24,i,j,k)=l2xi*l3eta*l2pgamma
+ dershape3D(3,25,i,j,k)=l1xi*l2eta*l2pgamma
+ dershape3D(3,26,i,j,k)=l2xi*l2eta*l3pgamma
+
+! center node
+
+ shape3D(27,i,j,k)=l2xi*l2eta*l2gamma
+
+ dershape3D(1,27,i,j,k)=l2pxi*l2eta*l2gamma
+ dershape3D(2,27,i,j,k)=l2xi*l2peta*l2gamma
+ dershape3D(3,27,i,j,k)=l2xi*l2eta*l2pgamma
+
+ enddo
+ enddo
+ enddo
+
+! check the shape functions
+ do i=1,NGLLX
+ do j=1,NGLLY
+ do k=1,NGLLZ
+
+ sumshape=ZERO
+
+ sumdershapexi=ZERO
+ sumdershapeeta=ZERO
+ sumdershapegamma=ZERO
+
+ do ia=1,NGNOD
+
+ sumshape=sumshape+shape3D(ia,i,j,k)
+
+ sumdershapexi=sumdershapexi+dershape3D(1,ia,i,j,k)
+ sumdershapeeta=sumdershapeeta+dershape3D(2,ia,i,j,k)
+ sumdershapegamma=sumdershapegamma+dershape3D(3,ia,i,j,k)
+
+ enddo
+
+! the sum of the shape functions should be 1
+ if(abs(sumshape-ONE) > TINYVAL) call exit_MPI(myrank,'error in 3D shape functions')
+
+! the sum of the derivatives of the shape functions should be 0
+ if(abs(sumdershapexi) > TINYVAL) &
+ call exit_MPI(myrank,'error in xi derivatives of 3D shape function')
+
+ if(abs(sumdershapeeta) > TINYVAL) &
+ call exit_MPI(myrank,'error in eta derivatives of 3D shape function')
+
+ if(abs(sumdershapegamma) > TINYVAL) &
+ call exit_MPI(myrank,'error in gamma derivatives of 3D shape function')
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine get_shape3D
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_value_parameters.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_value_parameters.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_value_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_value_parameters.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,84 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_value_integer(value_to_get, name, default_value)
+
+ implicit none
+
+ integer value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_integer
+
+!--------------------
+
+ subroutine get_value_double_precision(value_to_get, name, default_value)
+
+ implicit none
+
+ double precision value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_double_precision
+
+!--------------------
+
+ subroutine get_value_logical(value_to_get, name, default_value)
+
+ implicit none
+
+ logical value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_logical
+
+!--------------------
+
+ subroutine get_value_string(value_to_get, name, default_value)
+
+ implicit none
+
+ character(len=*) value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_string
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/gll_library.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/gll_library.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/gll_library.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/gll_library.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,529 @@
+
+!=======================================================================
+!
+! Library to compute the Gauss-Lobatto-Legendre points and weights
+! Based on Gauss-Lobatto routines from M.I.T.
+! Department of Mechanical Engineering
+!
+!=======================================================================
+
+ double precision function endw1(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ f3 = zero
+ apb = alpha+beta
+ if (n == 0) then
+ endw1 = zero
+ return
+ endif
+ f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw1 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw1 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw1 = f3
+
+ end function endw1
+
+!
+!=======================================================================
+!
+
+ double precision function endw2(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ apb = alpha+beta
+ f3 = zero
+ if (n == 0) then
+ endw2 = zero
+ return
+ endif
+ f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw2 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw2 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw2 = f3
+
+ end function endw2
+
+!
+!=======================================================================
+!
+
+ double precision function gammaf (x)
+
+ implicit none
+
+ double precision, parameter :: pi = 3.141592653589793d0
+
+ double precision x
+
+ double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
+
+ gammaf = one
+
+ if (x == -half) gammaf = -two*dsqrt(pi)
+ if (x == half) gammaf = dsqrt(pi)
+ if (x == one ) gammaf = one
+ if (x == two ) gammaf = one
+ if (x == 1.5d0) gammaf = dsqrt(pi)/2.d0
+ if (x == 2.5d0) gammaf = 1.5d0*dsqrt(pi)/2.d0
+ if (x == 3.5d0) gammaf = 2.5d0*1.5d0*dsqrt(pi)/2.d0
+ if (x == 3.d0 ) gammaf = 2.d0
+ if (x == 4.d0 ) gammaf = 6.d0
+ if (x == 5.d0 ) gammaf = 24.d0
+ if (x == 6.d0 ) gammaf = 120.d0
+
+ end function gammaf
+
+!
+!=====================================================================
+!
+
+ subroutine jacg (xjac,np,alpha,beta)
+
+!=======================================================================
+!
+! computes np Gauss points, which are the zeros of the
+! Jacobi polynomial with parameters alpha and beta
+!
+! .alpha = beta = 0.0 -> Legendre points
+! .alpha = beta = -0.5 -> Chebyshev points
+!
+!=======================================================================
+
+ implicit none
+
+ integer np
+ double precision alpha,beta
+ double precision xjac(np)
+
+ integer k,j,i,jmin,jm,n
+ double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+
+ integer, parameter :: K_MAX_ITER = 10
+ double precision, parameter :: zero = 0.d0, eps = 1.0d-12
+
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ xlast = 0.d0
+ n = np-1
+ dth = 4.d0*datan(1.d0)/(2.d0*dble(n)+2.d0)
+ p = 0.d0
+ pd = 0.d0
+ jmin = 0
+ do j=1,np
+ if(j == 1) then
+ x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ else
+ x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ x2 = xlast
+ x = (x1+x2)/2.d0
+ endif
+ do k=1,K_MAX_ITER
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
+ recsum = 0.d0
+ jm = j-1
+ do i=1,jm
+ recsum = recsum+1.d0/(x-xjac(np-i+1))
+ enddo
+ delx = -p/(pd-recsum*p)
+ x = x+delx
+ if(abs(delx) < eps) goto 31
+ enddo
+ 31 continue
+ xjac(np-j+1) = x
+ xlast = x
+ enddo
+ do i=1,np
+ xmin = 2.d0
+ do j=i,np
+ if(xjac(j) < xmin) then
+ xmin = xjac(j)
+ jmin = j
+ endif
+ enddo
+ if(jmin /= i) then
+ swap = xjac(i)
+ xjac(i) = xjac(jmin)
+ xjac(jmin) = swap
+ endif
+ enddo
+
+ end subroutine jacg
+
+!
+!=====================================================================
+!
+
+ subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
+
+!=======================================================================
+!
+! Computes the Jacobi polynomial of degree n and its derivative at x
+!
+!=======================================================================
+
+ implicit none
+
+ double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
+ integer n
+
+ double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
+ integer k
+
+ apb = alp+bet
+ poly = 1.d0
+ pder = 0.d0
+ psave = 0.d0
+ pdsave = 0.d0
+
+ if (n == 0) return
+
+ polyl = poly
+ pderl = pder
+ poly = (alp-bet+(apb+2.d0)*x)/2.d0
+ pder = (apb+2.d0)/2.d0
+ if (n == 1) return
+
+ do k=2,n
+ dk = dble(k)
+ a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
+ a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
+ b3 = (2.d0*dk+apb-2.d0)
+ a3 = b3*(b3+1.d0)*(b3+2.d0)
+ a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
+ polyn = ((a2+a3*x)*poly-a4*polyl)/a1
+ pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
+ psave = polyl
+ pdsave = pderl
+ polyl = poly
+ poly = polyn
+ pderl = pder
+ pder = pdern
+ enddo
+
+ polym1 = polyl
+ pderm1 = pderl
+ polym2 = psave
+ pderm2 = pdsave
+
+ end subroutine jacobf
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNDLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the derivative of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P1D,P2D,P3D,FK,P3
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P1D = 0.d0
+ P2D = 1.d0
+ P3D = 1.d0
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
+ P1 = P2
+ P2 = P3
+ P1D = P2D
+ P2D = P3D
+ enddo
+
+ PNDLEG = P3D
+
+ end function pndleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P3,FK
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P3 = P2
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P1 = P2
+ P2 = P3
+ enddo
+
+ PNLEG = P3
+
+ end function pnleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision function pnormj (n,alpha,beta)
+
+ implicit none
+
+ double precision alpha,beta
+ integer n
+
+ double precision one,two,dn,const,prod,dindx,frac
+ double precision, external :: gammaf
+ integer i
+
+ one = 1.d0
+ two = 2.d0
+ dn = dble(n)
+ const = alpha+beta+one
+
+ if (n <= 1) then
+ prod = gammaf(dn+alpha)*gammaf(dn+beta)
+ prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
+ pnormj = prod * two**const/(two*dn+const)
+ return
+ endif
+
+ prod = gammaf(alpha+one)*gammaf(beta+one)
+ prod = prod/(two*(one+const)*gammaf(const+one))
+ prod = prod*(one+alpha)*(two+alpha)
+ prod = prod*(one+beta)*(two+beta)
+
+ do i=3,n
+ dindx = dble(i)
+ frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
+ prod = prod*frac
+ enddo
+
+ pnormj = prod * two**const/(two*dn+const)
+
+ end function pnormj
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgjd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g j d : Generate np Gauss-Jacobi points and weights
+! associated with Jacobi polynomial of degree n = np-1
+!
+! Note : Coefficients alpha and beta must be greater than -1.
+! ----
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision z(np),w(np)
+ double precision alpha,beta
+
+ integer n,np1,np2,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
+ double precision, external :: gammaf,pnormj
+
+ pd = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ apb = alpha+beta
+ p = zero
+ pdm1 = zero
+
+ if (np <= 0) stop 'minimum number of Gauss points is 1'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (np == 1) then
+ z(1) = (beta-alpha)/(apb+two)
+ w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
+ return
+ endif
+
+ call jacg(z,np,alpha,beta)
+
+ np1 = n+1
+ np2 = n+2
+ dnp1 = dble(np1)
+ dnp2 = dble(np2)
+ fac1 = dnp1+alpha+beta+one
+ fac2 = fac1+dnp1
+ fac3 = fac2+one
+ fnorm = pnormj(np1,alpha,beta)
+ rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
+ do i=1,np
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
+ w(i) = -rcoef/(p*pdm1)
+ enddo
+
+ end subroutine zwgjd
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgljd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
+! ----------- weights associated with Jacobi polynomials of degree
+! n = np-1.
+!
+! Note : alpha and beta coefficients must be greater than -1.
+! Legendre polynomials are special case of Jacobi polynomials
+! just by setting alpha and beta to 0.
+!
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision alpha,beta
+ double precision z(np), w(np)
+
+ integer n,nm1,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision alpg,betg
+ double precision, external :: endw1,endw2
+
+ p = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ nm1 = n-1
+ pd = zero
+
+ if (np <= 1) stop 'minimum number of Gauss-Lobatto points is 2'
+
+! with spectral elements, use at least 3 points
+ if (np <= 2) stop 'minimum number of Gauss-Lobatto points for the SEM is 3'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (nm1 > 0) then
+ alpg = alpha+one
+ betg = beta+one
+ call zwgjd(z(2),w(2),nm1,alpg,betg)
+ endif
+
+ z(1) = - one
+ z(np) = one
+
+ do i=2,np-1
+ w(i) = w(i)/(one-z(i)**2)
+ enddo
+
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
+ w(1) = endw1(n,alpha,beta)/(two*pd)
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
+ w(np) = endw2(n,alpha,beta)/(two*pd)
+
+ end subroutine zwgljd
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/hex_nodes.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/hex_nodes.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/hex_nodes.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/hex_nodes.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,160 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 hex_nodes(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+! topology of the elements
+ integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
+
+! define the topology of the hexahedral elements
+
+! the topology of the nodes is described in UTILS/chunk_notes_scanned/numbering_convention_27_nodes.tif
+
+ if(NGNOD /= 27) stop 'elements should have 27 control nodes'
+
+! corner nodes
+
+ iaddx(1) = 0
+ iaddy(1) = 0
+ iaddz(1) = 0
+
+ iaddx(2) = 2
+ iaddy(2) = 0
+ iaddz(2) = 0
+
+ iaddx(3) = 2
+ iaddy(3) = 2
+ iaddz(3) = 0
+
+ iaddx(4) = 0
+ iaddy(4) = 2
+ iaddz(4) = 0
+
+ iaddx(5) = 0
+ iaddy(5) = 0
+ iaddz(5) = 2
+
+ iaddx(6) = 2
+ iaddy(6) = 0
+ iaddz(6) = 2
+
+ iaddx(7) = 2
+ iaddy(7) = 2
+ iaddz(7) = 2
+
+ iaddx(8) = 0
+ iaddy(8) = 2
+ iaddz(8) = 2
+
+! midside nodes (nodes located in the middle of an edge)
+
+ iaddx(9) = 1
+ iaddy(9) = 0
+ iaddz(9) = 0
+
+ iaddx(10) = 2
+ iaddy(10) = 1
+ iaddz(10) = 0
+
+ iaddx(11) = 1
+ iaddy(11) = 2
+ iaddz(11) = 0
+
+ iaddx(12) = 0
+ iaddy(12) = 1
+ iaddz(12) = 0
+
+ iaddx(13) = 0
+ iaddy(13) = 0
+ iaddz(13) = 1
+
+ iaddx(14) = 2
+ iaddy(14) = 0
+ iaddz(14) = 1
+
+ iaddx(15) = 2
+ iaddy(15) = 2
+ iaddz(15) = 1
+
+ iaddx(16) = 0
+ iaddy(16) = 2
+ iaddz(16) = 1
+
+ iaddx(17) = 1
+ iaddy(17) = 0
+ iaddz(17) = 2
+
+ iaddx(18) = 2
+ iaddy(18) = 1
+ iaddz(18) = 2
+
+ iaddx(19) = 1
+ iaddy(19) = 2
+ iaddz(19) = 2
+
+ iaddx(20) = 0
+ iaddy(20) = 1
+ iaddz(20) = 2
+
+! side center nodes (nodes located in the middle of a face)
+
+ iaddx(21) = 1
+ iaddy(21) = 1
+ iaddz(21) = 0
+
+ iaddx(22) = 1
+ iaddy(22) = 0
+ iaddz(22) = 1
+
+ iaddx(23) = 2
+ iaddy(23) = 1
+ iaddz(23) = 1
+
+ iaddx(24) = 1
+ iaddy(24) = 2
+ iaddz(24) = 1
+
+ iaddx(25) = 0
+ iaddy(25) = 1
+ iaddz(25) = 1
+
+ iaddx(26) = 1
+ iaddy(26) = 1
+ iaddz(26) = 2
+
+! center node (barycenter of the eight corners)
+
+ iaddx(27) = 1
+ iaddy(27) = 1
+ iaddz(27) = 1
+
+ end subroutine hex_nodes
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/intgrl.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/intgrl.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/intgrl.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/intgrl.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,185 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 intgrl(sum,r,nir,ner,f,s1,s2,s3)
+
+! Computes the integral of f[i]*r[i]*r[i] from i=nir to i=ner for
+! radii values as in model PREM_an640
+
+ implicit none
+
+! Argument variables
+ integer ner,nir
+ double precision f(640),r(640),s1(640),s2(640)
+ double precision s3(640),sum
+
+! Local variables
+ integer i,j,n,kdis(28)
+ integer ndis,nir1
+ double precision rji,yprime(640)
+
+ double precision, parameter :: third = 1.0d0/3.0d0
+ double precision, parameter :: fifth = 1.0d0/5.0d0
+ double precision, parameter :: sixth = 1.0d0/6.0d0
+
+ data kdis/163,323,336,517,530,540,565,590,609,619,626,633,16*0/
+
+ ndis = 12
+ n = 640
+
+ call deriv(f,yprime,n,r,ndis,kdis,s1,s2,s3)
+ nir1 = nir + 1
+ sum = 0.0d0
+ do i=nir1,ner
+ j = i-1
+ rji = r(i) - r(j)
+ sum=sum+r(j)*r(j)*rji*(f(j)+rji*(.50d0*s1(j)+rji*(third*s2(j)+rji* &
+ .250d0*s3(j))))+2.0d0*r(j)*rji*rji*(.50d0*f(j)+rji*(third*s1(j)+rji* &
+ (.250d0*s2(j)+rji*fifth*s3(j))))+rji*rji*rji*(third*f(j)+rji* &
+ (.250d0*s1(j)+rji*(fifth*s2(j)+rji*sixth*s3(j))))
+ enddo
+
+ end subroutine intgrl
+
+! -------------------------------
+
+ subroutine deriv(y,yprime,n,r,ndis,kdis,s1,s2,s3)
+
+ implicit none
+
+! Argument variables
+ integer kdis(28),n,ndis
+ double precision r(n),s1(n),s2(n),s3(n)
+ double precision y(n),yprime(n)
+
+! Local variables
+ integer i,j,j1,j2
+ integer k,nd,ndp
+ double precision a0,b0,b1
+ double precision f(3,1000),h,h2,h2a
+ double precision h2b,h3a,ha,s13
+ double precision s21,s32,yy(3)
+
+ yy(1) = 0.d0
+ yy(2) = 0.d0
+ yy(3) = 0.d0
+
+ ndp=ndis+1
+ do 3 nd=1,ndp
+ if(nd == 1) goto 4
+ if(nd == ndp) goto 5
+ j1=kdis(nd-1)+1
+ j2=kdis(nd)-2
+ goto 6
+ 4 j1=1
+ j2=kdis(1)-2
+ goto 6
+ 5 j1=kdis(ndis)+1
+ j2=n-2
+ 6 if((j2+1-j1)>0) goto 11
+ j2=j2+2
+ yy(1)=(y(j2)-y(j1))/(r(j2)-r(j1))
+ s1(j1)=yy(1)
+ s1(j2)=yy(1)
+ s2(j1)=yy(2)
+ s2(j2)=yy(2)
+ s3(j1)=yy(3)
+ s3(j2)=yy(3)
+ goto 3
+ 11 a0=0.0d0
+ if(j1 == 1) goto 7
+ h=r(j1+1)-r(j1)
+ h2=r(j1+2)-r(j1)
+ yy(1)=h*h2*(h2-h)
+ h=h*h
+ h2=h2*h2
+ b0=(y(j1)*(h-h2)+y(j1+1)*h2-y(j1+2)*h)/yy(1)
+ goto 8
+ 7 b0=0.0d0
+ 8 b1=b0
+
+ if(j2 > 1000) stop 'error in subroutine deriv for j2'
+
+ do i=j1,j2
+ h=r(i+1)-r(i)
+ yy(1)=y(i+1)-y(i)
+ h2=h*h
+ ha=h-a0
+ h2a=h-2.0d0*a0
+ h3a=2.0d0*h-3.0d0*a0
+ h2b=h2*b0
+ s1(i)=h2/ha
+ s2(i)=-ha/(h2a*h2)
+ s3(i)=-h*h2a/h3a
+ f(1,i)=(yy(1)-h*b0)/(h*ha)
+ f(2,i)=(h2b-yy(1)*(2.0d0*h-a0))/(h*h2*h2a)
+ f(3,i)=-(h2b-3.0d0*yy(1)*ha)/(h*h3a)
+ a0=s3(i)
+ b0=f(3,i)
+ enddo
+
+ i=j2+1
+ h=r(i+1)-r(i)
+ yy(1)=y(i+1)-y(i)
+ h2=h*h
+ ha=h-a0
+ h2a=h*ha
+ h2b=h2*b0-yy(1)*(2.d0*h-a0)
+ s1(i)=h2/ha
+ f(1,i)=(yy(1)-h*b0)/h2a
+ ha=r(j2)-r(i+1)
+ yy(1)=-h*ha*(ha+h)
+ ha=ha*ha
+ yy(1)=(y(i+1)*(h2-ha)+y(i)*ha-y(j2)*h2)/yy(1)
+ s3(i)=(yy(1)*h2a+h2b)/(h*h2*(h-2.0d0*a0))
+ s13=s1(i)*s3(i)
+ s2(i)=f(1,i)-s13
+
+ do j=j1,j2
+ k=i-1
+ s32=s3(k)*s2(i)
+ s1(i)=f(3,k)-s32
+ s21=s2(k)*s1(i)
+ s3(k)=f(2,k)-s21
+ s13=s1(k)*s3(k)
+ s2(k)=f(1,k)-s13
+ i=k
+ enddo
+
+ s1(i)=b1
+ j2=j2+2
+ s1(j2)=yy(1)
+ s2(j2)=yy(2)
+ s3(j2)=yy(3)
+ 3 continue
+
+ do i=1,n
+ yprime(i)=s1(i)
+ enddo
+
+ end subroutine deriv
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/jp3d1994_model.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/jp3d1994_model.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/jp3d1994_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/jp3d1994_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,1265 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+
+!=====================================================================
+!
+! Last Time Modified by Min Chen, Caltech, 03/14/2008
+!
+! Program ----- veljp3d.f -----
+!
+! This program is used to calculate 3-D P-wave velocity
+! distribution beneath the Japan Islands which is obtained
+! by a simultaneous inversion of arrival time data from local,
+! regional and teleseismic events. For details, see "Deep
+! structure of the Japan subduction zone as derived from local,
+! regional, and teleseismic events" by Zhao, Hasegawa & Kanamori,
+! JGR, 99, 22313-22329, 1994.
+!
+! The meaningful range of this model is as follows:
+! latitude : 32 - 45 N
+! longitude: 130-145 E
+! depth : 0 - 500 km
+!
+! Dapeng Zhao
+! Dept. of Earth & Planet. Sci
+! Washington University
+! St. Louis, MO 63130
+! U.S.A.
+! dapeng at izu.wustl.edu
+!=========================================================================
+subroutine read_iso3d_dpzhao_model(JP3DM_V)
+
+ implicit none
+
+ include "constants.h"
+! 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
+
+ OPEN(2,FILE="DATA/Zhao_JP_model/m3d1341")
+ OPEN(3,FILE="DATA/Zhao_JP_model/datadis")
+
+ CALL INPUTJP(JP3DM_V)
+ CALL INPUT1(JP3DM_V)
+ CALL INPUT2(JP3DM_V)
+
+end subroutine read_iso3d_dpzhao_model
+!==========================================================================
+subroutine iso3d_dpzhao_model(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+ logical found_crust
+ double precision :: radius,theta,phi,vp,vs,dvs,dvp,rho
+ double precision :: PE,RE,HE,H1,H2,H3,scaleval
+ integer :: LAY
+
+
+ found_crust = .false.
+
+ PE = theta
+ RE = phi
+ HE = (ONE - radius)*R_EARTH_KM
+! calculate depths of the Conrad, the Moho and
+! the plate boundary beneath the location (PHI,RAM)
+ CALL HLAY(PE,RE,H1,1,JP3DM_V)
+ CALL HLAY(PE,RE,H2,2,JP3DM_V)
+ CALL HLAY(PE,RE,H3,3,JP3DM_V)
+! when LAY = 1, the focus is in the upper crust;
+! when LAY = 2, the focus is in the lower crust;
+! when LAY = 3, the focus is in the mantle wedge;
+! when LAY = 4, the focus is beneath the plate boundary.
+ IF(HE.LE.H1) THEN
+ LAY = 1
+ found_crust = .true.
+ ELSE IF(HE.GT.H1.AND.HE.LE.H2) THEN
+ LAY = 2
+ found_crust = .true.
+ ELSE IF(HE.GT.H2.AND.HE.LE.H3) THEN
+ LAY = 3
+ ELSE
+ LAY = 4
+ END IF
+ CALL VEL1D(HE,vp,LAY,1,JP3DM_V)
+ CALL VEL1D(HE,vs,LAY,2,JP3DM_V)
+
+ CALL VEL3(PE,RE,HE,dvp,LAY,JP3DM_V)
+ dvp = 0.01d0*dvp
+ dvs = 1.5d0*dvp
+ vp = vp*(1.0d0+dvp)
+ vs = vs*(1.0d0+dvs)
+
+! determine rho
+ if(LAY .eq. 1) then
+ rho=2.6
+ endif
+ if(LAY .eq. 2) then
+ rho=2.9
+ endif
+ if(LAY .GT. 2) then
+ rho=3.3+(vs-4.4)*0.66667
+ endif
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+END subroutine iso3d_dpzhao_model
+
+!---------------------------------------------------------------
+
+ SUBROUTINE INPUT1(JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! 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
+
+100 FORMAT(3I3)
+ READ(2,100) JP3DM_V%NPA,JP3DM_V%NRA,JP3DM_V%NHA
+ CALL PUT1(JP3DM_V%NPA,JP3DM_V%NRA,JP3DM_V%NHA,JP3DM_V%PNA,JP3DM_V%RNA,JP3DM_V%HNA,JP3DM_V%VELAP)
+ READ(2,100) JP3DM_V%NPB,JP3DM_V%NRB,JP3DM_V%NHB
+ CALL PUT1(JP3DM_V%NPB,JP3DM_V%NRB,JP3DM_V%NHB,JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,JP3DM_V%VELBP)
+ CALL BLDMAP(JP3DM_V)
+ RETURN
+ END SUBROUTINE INPUT1
+
+ SUBROUTINE PUT1(NPX,NRX,NHX,PNX,RNX,HNX,VELXP)
+ integer :: NPX,NRX,NHX,K,I,J
+ double precision :: VELXP(NPX,NRX,NHX), &
+ PNX(NPX),RNX(NRX),HNX(NHX)
+ READ(2,110) (PNX(I),I=1,NPX)
+ READ(2,110) (RNX(I),I=1,NRX)
+ READ(2,120) (HNX(I),I=1,NHX)
+ DO K = 1,NHX
+ DO I = 1,NPX
+ READ(2,140) (VELXP(I,J,K),J=1,NRX)
+110 FORMAT(6(9F7.2/))
+120 FORMAT(3(8F7.2/))
+140 FORMAT(4(14F5.2/))
+ enddo
+ enddo
+ END SUBROUTINE PUT1
+
+ SUBROUTINE INPUT2(JP3DM_V)
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+ integer :: NP,NNR,I,J
+ READ(3,100) NP,NNR
+ READ(3,110) (JP3DM_V%PN(I),I=1,NP)
+ READ(3,120) (JP3DM_V%RRN(I),I=1,NNR)
+ DO 1 I = NP,1,-1
+ READ(3,130) (JP3DM_V%DEPA(I,J),J=1,NNR)
+1 CONTINUE
+ DO 2 I = NP,1,-1
+ READ(3,130) (JP3DM_V%DEPB(I,J),J=1,NNR)
+2 CONTINUE
+ DO 3 I = NP,1,-1
+ READ(3,130) (JP3DM_V%DEPC(I,J),J=1,NNR)
+3 CONTINUE
+100 FORMAT(2I6)
+110 FORMAT(5(10F7.2/),F7.2)
+120 FORMAT(6(10F7.2/),3F7.2)
+130 FORMAT(6(10F7.1/),3F7.1)
+ RETURN
+ END
+
+ SUBROUTINE BLDMAP(JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! 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
+
+ CALL LOCX(JP3DM_V%PNA,JP3DM_V%RNA,JP3DM_V%HNA,JP3DM_V%NPA,JP3DM_V%NRA,JP3DM_V%NHA,MKA, &
+ JP3DM_V%PLA,JP3DM_V%RLA,JP3DM_V%HLA,JP3DM_V%IPLOCA,JP3DM_V%IRLOCA,JP3DM_V%IHLOCA)
+ CALL LOCX(JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,JP3DM_V%NPB,JP3DM_V%NRB,JP3DM_V%NHB,MKB, &
+ JP3DM_V%PLB,JP3DM_V%RLB,JP3DM_V%HLB,JP3DM_V%IPLOCB,JP3DM_V%IRLOCB,JP3DM_V%IHLOCB)
+ RETURN
+ END
+
+ SUBROUTINE LOCX(PNX,RNX,HNX,NPX,NRX,NHX,MKX, &
+ PLX,RLX,HLX,IPLOCX,IRLOCX,IHLOCX)
+ integer :: NPX,NRX,NHX,MKX,IPLOCX(MKX),IRLOCX(MKX),IHLOCX(MKX)
+ integer :: IPMAX,IP,IP1,IRMAX,IR,IR1,IH1,IH,IHMAX,I
+ double precision :: PNX(NPX),RNX(NRX),HNX(NHX)
+ double precision :: PLX,RLX,HLX,PNOW,RNOW,HNOW
+ PLX = 1.0-PNX(1)*100.0
+ IPMAX = IDNINT(PNX(NPX)*100.0+PLX)
+ IP = 1
+ DO 10 I = 1,IPMAX
+ IP1 = IP+1
+ PNOW = (FLOAT(I)-PLX)/100.0
+ IF(PNOW.GE.PNX(IP1)) IP = IP1
+ IPLOCX(I)= IP
+10 CONTINUE
+ RLX = 1.0-RNX(1)*100.0
+ IRMAX = IDNINT(RNX(NRX)*100.0+RLX)
+ IR = 1
+ DO 20 I = 1,IRMAX
+ IR1 = IR+1
+ RNOW = (FLOAT(I)-RLX)/100.0
+ IF(RNOW.GE.RNX(IR1)) IR = IR1
+ IRLOCX(I)= IR
+20 CONTINUE
+ HLX = 1.0-HNX(1)
+ IHMAX = IDNINT(HNX(NHX)+HLX)
+ IH = 1
+ DO 30 I = 1,IHMAX
+ IH1 = IH+1
+ HNOW = FLOAT(I)-HLX
+ IF(HNOW.GE.HNX(IH1)) IH = IH1
+ IHLOCX(I)= IH
+30 CONTINUE
+ RETURN
+ END
+
+ SUBROUTINE VEL3(PE,RE,HE,V,LAY,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! 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
+
+ double precision :: PE,RE,HE,V
+
+ integer :: LAY
+
+ JP3DM_V%P = 90.0-PE/DEGREES_TO_RADIANS
+ JP3DM_V%R = RE/DEGREES_TO_RADIANS
+ JP3DM_V%H = HE
+ IF(LAY.LE.3) THEN
+ CALL PRHF(JP3DM_V%IPLOCA,JP3DM_V%IRLOCA,JP3DM_V%IHLOCA,JP3DM_V%PLA,JP3DM_V%RLA,JP3DM_V%HLA, &
+ JP3DM_V%PNA,JP3DM_V%RNA,JP3DM_V%HNA,MPA,MRA,MHA,MKA,JP3DM_V)
+ ELSE IF(LAY.EQ.4) THEN
+ CALL PRHF(JP3DM_V%IPLOCB,JP3DM_V%IRLOCB,JP3DM_V%IHLOCB,JP3DM_V%PLB,JP3DM_V%RLB,JP3DM_V%HLB, &
+ JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,MPB,MRB,MHB,MKB,JP3DM_V)
+ ELSE
+ END IF
+ JP3DM_V%WV(1) = JP3DM_V%PF1*JP3DM_V%RF1*JP3DM_V%HF1
+ JP3DM_V%WV(2) = JP3DM_V%PF*JP3DM_V%RF1*JP3DM_V%HF1
+ JP3DM_V%WV(3) = JP3DM_V%PF1*JP3DM_V%RF*JP3DM_V%HF1
+ JP3DM_V%WV(4) = JP3DM_V%PF*JP3DM_V%RF*JP3DM_V%HF1
+ JP3DM_V%WV(5) = JP3DM_V%PF1*JP3DM_V%RF1*JP3DM_V%HF
+ JP3DM_V%WV(6) = JP3DM_V%PF*JP3DM_V%RF1*JP3DM_V%HF
+ JP3DM_V%WV(7) = JP3DM_V%PF1*JP3DM_V%RF*JP3DM_V%HF
+ JP3DM_V%WV(8) = JP3DM_V%PF*JP3DM_V%RF*JP3DM_V%HF
+ ! calculate velocity
+ IF(LAY.LE.3) THEN
+ CALL VABPS(MPA,MRA,MHA,JP3DM_V%VELAP,V,JP3DM_V)
+ ELSE IF(LAY.EQ.4) THEN
+ CALL VABPS(MPB,MRB,MHB,JP3DM_V%VELBP,V,JP3DM_V)
+ ELSE
+ END IF
+
+ RETURN
+ END SUBROUTINE VEL3
+
+ SUBROUTINE VABPS(MP,MR,MH,V,VEL,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+
+
+! 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
+ double precision :: VEL
+ integer :: MP,MR,MH
+ double precision :: V(MP,MR,MH)
+ VEL = JP3DM_V%WV(1)*V(JP3DM_V%IP,JP3DM_V%JP,JP3DM_V%KP) + JP3DM_V%WV(2)*V(JP3DM_V%IP1,JP3DM_V%JP,JP3DM_V%KP) &
+ + JP3DM_V%WV(3)*V(JP3DM_V%IP,JP3DM_V%JP1,JP3DM_V%KP) + JP3DM_V%WV(4)*V(JP3DM_V%IP1,JP3DM_V%JP1,JP3DM_V%KP) &
+ + JP3DM_V%WV(5)*V(JP3DM_V%IP,JP3DM_V%JP,JP3DM_V%KP1) + JP3DM_V%WV(6)*V(JP3DM_V%IP1,JP3DM_V%JP,JP3DM_V%KP1) &
+ + JP3DM_V%WV(7)*V(JP3DM_V%IP,JP3DM_V%JP1,JP3DM_V%KP1)+ JP3DM_V%WV(8)*V(JP3DM_V%IP1,JP3DM_V%JP1,JP3DM_V%KP1)
+ RETURN
+ END
+
+ SUBROUTINE INTMAP(R,IRLOC,NNR,RL,IR)
+ integer :: NNR,IRLOC(NNR),IS,IR
+ double precision :: R,RL
+ IS = IDNINT(R+RL)
+ IR = IRLOC(IS)
+ RETURN
+ END
+
+ SUBROUTINE PRHF(IPLOCX,IRLOCX,IHLOCX,PLX,RLX,HLX, &
+ PNX,RNX,HNX,MPX,MRX,MHX,MKX,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+ integer :: MPX,MRX,MHX,MKX
+ integer :: IPLOCX(MKX),IRLOCX(MKX),IHLOCX(MKX)
+ double precision :: PNX(MPX),RNX(MRX),HNX(MHX)
+ double precision :: PLX,RLX,HLX
+ CALL LIMIT(PNX(1),PNX(MPX),JP3DM_V%P)
+ CALL LIMIT(RNX(1),RNX(MRX),JP3DM_V%R)
+ CALL LIMIT(HNX(1),HNX(MHX),JP3DM_V%H)
+ CALL INTMAP(JP3DM_V%P*100.0,IPLOCX,MKX,PLX,JP3DM_V%IP)
+ CALL INTMAP(JP3DM_V%R*100.0,IRLOCX,MKX,RLX,JP3DM_V%JP)
+ CALL INTMAP(JP3DM_V%H,IHLOCX,MKX,HLX,JP3DM_V%KP)
+ JP3DM_V%IP1 = JP3DM_V%IP+1
+ JP3DM_V%JP1 = JP3DM_V%JP+1
+ JP3DM_V%KP1 = JP3DM_V%KP+1
+ JP3DM_V%PD = PNX(JP3DM_V%IP1)-PNX(JP3DM_V%IP)
+ JP3DM_V%RD = RNX(JP3DM_V%JP1)-RNX(JP3DM_V%JP)
+ JP3DM_V%HD = HNX(JP3DM_V%KP1)-HNX(JP3DM_V%KP)
+ JP3DM_V%PF = (JP3DM_V%P-PNX(JP3DM_V%IP))/JP3DM_V%PD
+ JP3DM_V%RF = (JP3DM_V%R-RNX(JP3DM_V%JP))/JP3DM_V%RD
+ JP3DM_V%HF = (JP3DM_V%H-HNX(JP3DM_V%KP))/JP3DM_V%HD
+ JP3DM_V%PF1 = 1.0-JP3DM_V%PF
+ JP3DM_V%RF1 = 1.0-JP3DM_V%RF
+ JP3DM_V%HF1 = 1.0-JP3DM_V%HF
+ RETURN
+ END
+
+ SUBROUTINE HLAY(PE,RE,HE,IJK,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! 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
+ double precision :: PE,RE,HE,WV1,WV2,WV3,WV4,P,R,PF,RF,PF1,RF1
+ integer :: IJK,J,J1,I,I1
+ P = 90.0-PE/DEGREES_TO_RADIANS
+ R = RE/DEGREES_TO_RADIANS
+ CALL LIMIT(JP3DM_V%PN(1),JP3DM_V%PN(51),P)
+ CALL LIMIT(JP3DM_V%RRN(1),JP3DM_V%RRN(63),R)
+ DO 1 I = 1,50
+ I1 = I+1
+ IF(P.GE.JP3DM_V%PN(I).AND.P.LT.JP3DM_V%PN(I1)) GO TO 11
+1 CONTINUE
+11 CONTINUE
+ DO 2 J = 1,62
+ J1 = J+1
+ IF(R.GE.JP3DM_V%RRN(J).AND.R.LT.JP3DM_V%RRN(J1)) GO TO 22
+2 CONTINUE
+22 CONTINUE
+ PF = (P-JP3DM_V%PN(I))/(JP3DM_V%PN(I1)-JP3DM_V%PN(I))
+ RF = (R-JP3DM_V%RRN(J))/(JP3DM_V%RRN(J1)-JP3DM_V%RRN(J))
+ PF1 = 1.0-PF
+ RF1 = 1.0-RF
+ WV1 = PF1*RF1
+ WV2 = PF*RF1
+ WV3 = PF1*RF
+ WV4 = PF*RF
+ IF(IJK.EQ.1) THEN
+ HE = WV1*JP3DM_V%DEPA(I,J) + WV2*JP3DM_V%DEPA(I1,J) &
+ + WV3*JP3DM_V%DEPA(I,J1) + WV4*JP3DM_V%DEPA(I1,J1)
+ ELSE IF(IJK.EQ.2) THEN
+ HE = WV1*JP3DM_V%DEPB(I,J) + WV2*JP3DM_V%DEPB(I1,J) &
+ + WV3*JP3DM_V%DEPB(I,J1) + WV4*JP3DM_V%DEPB(I1,J1)
+ ELSE IF(IJK.EQ.3) THEN
+ HE = WV1*JP3DM_V%DEPC(I,J) + WV2*JP3DM_V%DEPC(I1,J) &
+ + WV3*JP3DM_V%DEPC(I,J1) + WV4*JP3DM_V%DEPC(I1,J1)
+ ELSE
+ END IF
+ RETURN
+ END SUBROUTINE HLAY
+
+ SUBROUTINE LIMIT(C1,C2,C)
+ double precision :: A1,A2,C1,C2,C
+ A1 = dmin1(C1,C2)
+ A2 = dmax1(C1,C2)
+ IF(C.LT.A1) C = A1
+ IF(C.GT.A2) C = A2
+ END SUBROUTINE LIMIT
+
+ SUBROUTINE VEL1D(HE,V,LAY,IPS,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! 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
+
+ integer :: IPS,LAY
+ double precision :: HE,V,VM,HM
+ IF(LAY.EQ.1) THEN
+ V = 6.0
+ IF(IPS.EQ.2) V = 3.5
+ ELSE IF(LAY.EQ.2) THEN
+ V = 6.7
+ IF(IPS.EQ.2) V = 3.8
+ ELSE IF(LAY.GE.3) THEN
+ HM = 40.0
+ IF(HE.LT.HM) THEN
+ CALL JPMODEL(IPS,HM,VM,JP3DM_V)
+ V = VM-(HM-HE)*0.003
+ ELSE
+ CALL JPMODEL(IPS,HE,V,JP3DM_V)
+ END IF
+ ELSE
+ END IF
+ RETURN
+ END
+
+ SUBROUTINE INPUTJP(JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! 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
+ double precision :: VP1(29),VS1(29),RA1(29)
+ integer :: L
+ DATA VP1/7.75, 7.94, 8.13, 8.33, 8.54, 8.75, 8.97, &
+ 9.50, 9.91,10.26,10.55,10.99,11.29,11.50, &
+ 11.67,11.85,12.03,12.20,12.37,12.54,12.71, &
+ 12.87,13.02,13.16,13.32,13.46,13.60,13.64,13.64/
+ DATA VS1/4.353,4.444,4.539,4.638,4.741,4.850,4.962, &
+ 5.227,5.463,5.670,5.850,6.125,6.295,6.395, &
+ 6.483,6.564,6.637,6.706,6.770,6.833,6.893, &
+ 6.953,7.012,7.074,7.137,7.199,7.258,7.314,7.304/
+ DATA RA1/1.00,0.99,0.98,0.97,0.96,0.95,0.94,0.93, &
+ 0.92,0.91,0.90,0.88,0.86,0.84,0.82,0.80, &
+ 0.78,0.76,0.74,0.72,0.70,0.68,0.66,0.64, &
+ 0.62,0.60,0.58,0.56,0.55/
+ DO 1 L = 1,29
+ JP3DM_V%VP(L) = VP1(L)
+ JP3DM_V%VS(L) = VS1(L)
+ JP3DM_V%RA(L) = RA1(L)
+ JP3DM_V%DEPJ(L) = 40.0+6325.59*(1.0-RA1(L))
+1 CONTINUE
+ RETURN
+ END
+
+ SUBROUTINE JPMODEL(IPS,H,V,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! 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
+ integer :: IPS,K,K1
+ double precision :: H1,H2,H12,H,V
+ DO 2 K = 1,28
+ K1 = K+1
+ H1 = JP3DM_V%DEPJ(K)
+ H2 = JP3DM_V%DEPJ(K1)
+ IF(H.GE.H1.AND.H.LT.H2) GO TO 3
+2 CONTINUE
+3 CONTINUE
+ H12 = (H-H1)/(H2-H1)
+ IF(IPS.EQ.1) THEN
+ V = (JP3DM_V%VP(K1)-JP3DM_V%VP(K))*H12+JP3DM_V%VP(K)
+ ELSE
+ V = (JP3DM_V%VS(K1)-JP3DM_V%VS(K))*H12+JP3DM_V%VS(K)
+ END IF
+ RETURN
+ END
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/lagrange_poly.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lagrange_poly.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/lagrange_poly.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/lagrange_poly.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -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 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 lagrange_any(xi,NGLL,xigll,h,hprime)
+
+! subroutine to compute the Lagrange interpolants based upon the GLL points
+! and their first derivatives at any point xi in [-1,1]
+
+ implicit none
+
+ integer NGLL
+ double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)
+
+ integer dgr,i,j
+ double precision prod1,prod2
+
+ do dgr=1,NGLL
+
+ prod1 = 1.0d0
+ prod2 = 1.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1 = prod1*(xi-xigll(i))
+ prod2 = prod2*(xigll(dgr)-xigll(i))
+ endif
+ enddo
+ h(dgr)=prod1/prod2
+
+ hprime(dgr)=0.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1=1.0d0
+ do j=1,NGLL
+ if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
+ enddo
+ hprime(dgr) = hprime(dgr)+prod1
+ endif
+ enddo
+ hprime(dgr) = hprime(dgr)/prod2
+
+ enddo
+
+ end subroutine lagrange_any
+
+!
+!=====================================================================
+!
+
+! subroutine to compute the derivative of the Lagrange interpolants
+! at the GLL points at any given GLL point
+
+ double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the derivative of the I-th
+! Lagrange interpolant through the
+! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
+!
+!------------------------------------------------------------------------
+
+ implicit none
+
+ integer i,j,nz
+ double precision zgll(0:nz-1)
+
+ integer degpoly
+
+ double precision, external :: pnleg,pndleg
+
+ degpoly = nz - 1
+ if (i == 0 .and. j == 0) then
+ lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == degpoly .and. j == degpoly) then
+ lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == j) then
+ lagrange_deriv_GLL = 0.d0
+ else
+ lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
+ (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
+ + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
+ (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
+ endif
+
+ end function lagrange_deriv_GLL
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/lgndr.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lgndr.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/lgndr.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/lgndr.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,152 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 lgndr(l,c,s,x,dx)
+
+! computes Legendre function x(l,m,theta)
+! theta=colatitude,c=cos(theta),s=sin(theta),l=angular order,
+! sin(theta) restricted so that sin(theta) > 1.e-7
+! x(1) contains m=0, x(2) contains m=1, x(k+1) contains m=k
+! m=azimuthal (longitudinal) order 0 <= m <= l
+! dx=dx/dtheta
+!
+! subroutine originally came from Physics Dept. Princeton through
+! Peter Davis, modified by Jeffrey Park
+
+ implicit none
+
+! argument variables
+ integer l
+ double precision x(2*l+1),dx(2*l+1)
+ double precision c,s
+
+! local variables
+ integer i,lp1,lpsafe,lsave
+ integer m,maxsin,mmm,mp1
+
+ double precision sqroot2over2,c1,c2,cot
+ double precision ct,d,f1,f2
+ double precision f3,fac,g1,g2
+ double precision g3,rfpi,sqroot3,sos
+ double precision ss,stom,t,tol
+ double precision v,y
+
+ tol = 1.d-05
+ rfpi = 0.282094791773880d0
+ sqroot3 = 1.73205080756890d0
+ sqroot2over2 = 0.707106781186550d0
+
+ if(s >= 1.0d0-tol) s=1.0d0-tol
+ lsave=l
+ if(l<0) l=-1-l
+ if(l>0) goto 1
+ x(1)=rfpi
+ dx(1)=0.0d0
+ l=lsave
+ return
+ 1 if(l /= 1) goto 2
+ c1=sqroot3*rfpi
+ c2=sqroot2over2*c1
+ x(1)=c1*c
+ x(2)=-c2*s
+ dx(1)=-c1*s
+ dx(2)=-c2*c
+ l=lsave
+ return
+ 2 sos=s
+ if(s<tol) s=tol
+ cot=c/s
+ ct=2.0d0*c
+ ss=s*s
+ lp1=l+1
+ g3=0.0d0
+ g2=1.0d0
+ f3=0.0d0
+
+! evaluate m=l value, sans (sin(theta))**l
+ do i=1,l
+ g2=g2*(1.0d0-1.0d0/(2.0d0*i))
+ enddo
+ g2=rfpi*dsqrt((2*l+1)*g2)
+ f2=l*cot*g2
+ x(lp1)=g2
+ dx(lp1)=f2
+ v=1.0d0
+ y=2.0d0*l
+ d=dsqrt(v*y)
+ t=0.0d0
+ mp1=l
+ m=l-1
+
+! these recursions are similar to ordinary m-recursions, but since we
+! have taken the s**m factor out of the xlm's, the recursion has the powers
+! of sin(theta) instead
+ 3 g1=-(ct*mp1*g2+ss*t*g3)/d
+ f1=(mp1*(2.0d0*s*g2-ct*f2)-t*ss*(f3+cot*g3))/d-cot*g1
+ x(mp1)=g1
+ dx(mp1)=f1
+ if(m == 0) goto 4
+ mp1=m
+ m=m-1
+ v=v+1.0d0
+ y=y-1.0d0
+ t=d
+ d=dsqrt(v*y)
+ g3=g2
+ g2=g1
+ f3=f2
+ f2=f1
+ goto 3
+! explicit conversion to integer added
+ 4 maxsin=int(-72.0d0/log10(s))
+
+! maxsin is the max exponent of sin(theta) without underflow
+ lpsafe=min0(lp1,maxsin)
+ stom=1.0d0
+ fac=sign(1.0d0,dble((l/2)*2-l) + 0.50d0)
+
+! multiply xlm by sin**m
+ do m=1,lpsafe
+ x(m)=fac*x(m)*stom
+ dx(m)=fac*dx(m)*stom
+ stom=stom*s
+ enddo
+
+! set any remaining xlm to zero
+ if(maxsin <= l) then
+ mmm=maxsin+1
+ do m=mmm,lp1
+ x(m)=0.0d0
+ dx(m)=0.0d0
+ enddo
+ endif
+
+ s=sos
+ l=lsave
+
+ end subroutine lgndr
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_receivers.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,680 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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, allocatable, dimension(:) :: ix_initial_guess,iy_initial_guess,iz_initial_guess
+
+ integer iorientation
+ integer iprocloop
+ double precision stazi,stdip
+
+ double precision, allocatable, dimension(:) :: x_target,y_target,z_target
+ double precision, allocatable, dimension(:) :: epidist
+ double precision, allocatable, dimension(:) :: x_found,y_found,z_found
+ double precision, allocatable, dimension(:,:) :: x_found_all,y_found_all,z_found_all
+
+ 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
+
+! use dynamic allocation
+ double precision, dimension(:), allocatable :: final_distance
+ double precision, dimension(:,:), allocatable :: final_distance_all
+ 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
+
+ integer, allocatable, dimension(:,:) :: ispec_selected_rec_all
+ double precision, dimension(nrec) :: stlat,stlon,stele
+ double precision, allocatable, dimension(:) :: stbur
+ double precision, allocatable, dimension(:,:) :: 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
+
+! allocate memory for arrays using number of stations
+ allocate(stbur(nrec))
+ allocate(epidist(nrec))
+
+ allocate(ix_initial_guess(nrec))
+ allocate(iy_initial_guess(nrec))
+ allocate(iz_initial_guess(nrec))
+ allocate(x_target(nrec))
+ allocate(y_target(nrec))
+ allocate(z_target(nrec))
+ allocate(x_found(nrec))
+ allocate(y_found(nrec))
+ allocate(z_found(nrec))
+ allocate(final_distance(nrec))
+
+ allocate(ispec_selected_rec_all(nrec,0:NPROCTOT-1))
+ allocate(xi_receiver_all(nrec,0:NPROCTOT-1))
+ allocate(eta_receiver_all(nrec,0:NPROCTOT-1))
+ allocate(gamma_receiver_all(nrec,0:NPROCTOT-1))
+ allocate(x_found_all(nrec,0:NPROCTOT-1))
+ allocate(y_found_all(nrec,0:NPROCTOT-1))
+ allocate(z_found_all(nrec,0:NPROCTOT-1))
+ allocate(final_distance_all(nrec,0:NPROCTOT-1))
+
+! 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')
+ 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')
+ 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_BARRIER(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)
+
+! deallocate arrays
+ deallocate(stbur)
+ deallocate(epidist)
+ deallocate(ix_initial_guess)
+ deallocate(iy_initial_guess)
+ deallocate(iz_initial_guess)
+ deallocate(x_target)
+ deallocate(y_target)
+ deallocate(z_target)
+ deallocate(x_found)
+ deallocate(y_found)
+ deallocate(z_found)
+ deallocate(final_distance)
+ deallocate(ispec_selected_rec_all)
+ deallocate(xi_receiver_all)
+ deallocate(eta_receiver_all)
+ deallocate(gamma_receiver_all)
+ deallocate(x_found_all)
+ deallocate(y_found_all)
+ deallocate(z_found_all)
+ deallocate(final_distance_all)
+
+ end subroutine locate_receivers
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_sources.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,706 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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, dimension(:), allocatable :: final_distance_source_subset
+
+ 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)
+ integer, dimension(:), allocatable :: ispec_selected_source_subset
+
+ integer, dimension(:,:), allocatable :: ispec_selected_source_all
+ double precision, dimension(:,:), allocatable :: 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 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(:), allocatable :: xi_source_subset,eta_source_subset,gamma_source_subset
+
+ 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, dimension(:), allocatable :: x_found_source,y_found_source,z_found_source
+ 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)
+
+! **************
+
+! 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)
+
+! allocate arrays specific to each subset
+ allocate(final_distance_source_subset(NSOURCES_SUBSET_current_size))
+
+ allocate(ispec_selected_source_subset(NSOURCES_SUBSET_current_size))
+
+ allocate(ispec_selected_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+
+ allocate(xi_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+ allocate(eta_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+ allocate(gamma_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+
+ allocate(final_distance_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+
+ allocate(x_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+ allocate(y_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+ allocate(z_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+
+ allocate(xi_source_subset(NSOURCES_SUBSET_current_size))
+ allocate(eta_source_subset(NSOURCES_SUBSET_current_size))
+ allocate(gamma_source_subset(NSOURCES_SUBSET_current_size))
+
+ allocate(x_found_source(NSOURCES_SUBSET_current_size))
+ allocate(y_found_source(NSOURCES_SUBSET_current_size))
+ allocate(z_found_source(NSOURCES_SUBSET_current_size))
+
+! 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(:,:) = -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(isource_in_this_subset,iprocloop) < distmin) then
+ distmin = final_distance_source_all(isource_in_this_subset,iprocloop)
+ islice_selected_source(isource) = iprocloop
+ ispec_selected_source(isource) = ispec_selected_source_all(isource_in_this_subset,iprocloop)
+ xi_source(isource) = xi_source_all(isource_in_this_subset,iprocloop)
+ eta_source(isource) = eta_source_all(isource_in_this_subset,iprocloop)
+ gamma_source(isource) = gamma_source_all(isource_in_this_subset,iprocloop)
+ x_found_source(isource_in_this_subset) = x_found_source_all(isource_in_this_subset,iprocloop)
+ y_found_source(isource_in_this_subset) = y_found_source_all(isource_in_this_subset,iprocloop)
+ z_found_source(isource_in_this_subset) = z_found_source_all(isource_in_this_subset,iprocloop)
+ 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'
+
+! 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')
+
+ scalar_moment = 0.
+ do i = 1,6
+ scalar_moment = scalar_moment + moment_tensor(i,isource)**2
+ enddo
+ scalar_moment = dsqrt(scalar_moment/2.)
+
+ 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')
+
+ 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
+
+! deallocate arrays specific to each subset
+ deallocate(final_distance_source_subset)
+ deallocate(ispec_selected_source_subset)
+ deallocate(ispec_selected_source_all)
+ deallocate(xi_source_all,eta_source_all,gamma_source_all,final_distance_source_all)
+ deallocate(x_found_source_all,y_found_source_all,z_found_source_all)
+ deallocate(xi_source_subset,eta_source_subset,gamma_source_subset)
+ deallocate(x_found_source,y_found_source,z_found_source)
+
+ enddo ! end of loop over all source subsets
+
+! 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/make_ellipticity.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_ellipticity.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/make_ellipticity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/make_ellipticity.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,175 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
+
+! creates a spline for the ellipticity profile in PREM
+! radius and density are non-dimensional
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspl
+
+ logical ONE_CRUST
+
+! radius of the Earth for gravity calculation
+ double precision, parameter :: R_EARTH_ELLIPTICITY = 6371000.d0
+! radius of the ocean floor for gravity calculation
+ double precision, parameter :: ROCEAN_ELLIPTICITY = 6368000.d0
+
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ integer i
+ double precision ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670, &
+ R771,RTOPDDOUBLEPRIME,RCMB,RICB
+ double precision r_icb,r_cmb,r_topddoubleprime,r_771,r_670,r_600
+ double precision r_400,r_220,r_80,r_moho,r_middle_crust,r_ocean,r_0
+ double precision r(NR),rho(NR),epsilonval(NR),eta(NR)
+ double precision radau(NR),z,k(NR),g_a,bom,exponentval,i_rho,i_radau
+ double precision s1(NR),s2(NR),s3(NR)
+ double precision yp1,ypn
+
+! 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
+
+! non-dimensionalize
+ r_icb = RICB/R_EARTH_ELLIPTICITY
+ r_cmb = RCMB/R_EARTH_ELLIPTICITY
+ r_topddoubleprime = RTOPDDOUBLEPRIME/R_EARTH_ELLIPTICITY
+ r_771 = R771/R_EARTH_ELLIPTICITY
+ r_670 = R670/R_EARTH_ELLIPTICITY
+ r_600 = R600/R_EARTH_ELLIPTICITY
+ r_400 = R400/R_EARTH_ELLIPTICITY
+ r_220 = R220/R_EARTH_ELLIPTICITY
+ r_80 = R80/R_EARTH_ELLIPTICITY
+ r_moho = RMOHO/R_EARTH_ELLIPTICITY
+ r_middle_crust = RMIDDLE_CRUST/R_EARTH_ELLIPTICITY
+ r_ocean = ROCEAN_ELLIPTICITY/R_EARTH_ELLIPTICITY
+ r_0 = 1.d0
+
+ do i=1,163
+ r(i) = r_icb*dble(i-1)/dble(162)
+ enddo
+ do i=164,323
+ r(i) = r_icb+(r_cmb-r_icb)*dble(i-164)/dble(159)
+ enddo
+ do i=324,336
+ r(i) = r_cmb+(r_topddoubleprime-r_cmb)*dble(i-324)/dble(12)
+ enddo
+ do i=337,517
+ r(i) = r_topddoubleprime+(r_771-r_topddoubleprime)*dble(i-337)/dble(180)
+ enddo
+ do i=518,530
+ r(i) = r_771+(r_670-r_771)*dble(i-518)/dble(12)
+ enddo
+ do i=531,540
+ r(i) = r_670+(r_600-r_670)*dble(i-531)/dble(9)
+ enddo
+ do i=541,565
+ r(i) = r_600+(r_400-r_600)*dble(i-541)/dble(24)
+ enddo
+ do i=566,590
+ r(i) = r_400+(r_220-r_400)*dble(i-566)/dble(24)
+ enddo
+ do i=591,609
+ r(i) = r_220+(r_80-r_220)*dble(i-591)/dble(18)
+ enddo
+ do i=610,619
+ r(i) = r_80+(r_moho-r_80)*dble(i-610)/dble(9)
+ enddo
+ do i=620,626
+ r(i) = r_moho+(r_middle_crust-r_moho)*dble(i-620)/dble(6)
+ enddo
+ do i=627,633
+ r(i) = r_middle_crust+(r_ocean-r_middle_crust)*dble(i-627)/dble(6)
+ enddo
+ do i=634,NR
+ r(i) = r_ocean+(r_0-r_ocean)*dble(i-634)/dble(6)
+ enddo
+
+
+! use PREM to get the density profile for ellipticity (fine for other 1D reference models)
+ do i=1,NR
+ call prem_density(r(i),rho(i),ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+ radau(i)=rho(i)*r(i)*r(i)
+ enddo
+
+ eta(1)=0.0d0
+
+ k(1)=0.0d0
+
+ do i=2,NR
+ call intgrl(i_rho,r,1,i,rho,s1,s2,s3)
+ call intgrl(i_radau,r,1,i,radau,s1,s2,s3)
+ z=(2.0d0/3.0d0)*i_radau/(i_rho*r(i)*r(i))
+ eta(i)=(25.0d0/4.0d0)*((1.0d0-(3.0d0/2.0d0)*z)**2.0d0)-1.0d0
+ k(i)=eta(i)/(r(i)**3.0d0)
+ enddo
+
+ g_a=4.0D0*i_rho
+ bom=TWO_PI/(24.0d0*3600.0d0)
+ bom=bom/sqrt(PI*GRAV*RHOAV)
+ epsilonval(NR)=15.0d0*(bom**2.0d0)/(24.0d0*i_rho*(eta(NR)+2.0d0))
+
+ do i=1,NR-1
+ call intgrl(exponentval,r,i,NR,k,s1,s2,s3)
+ epsilonval(i)=epsilonval(NR)*exp(-exponentval)
+ enddo
+
+! get ready to spline epsilonval
+ nspl=1
+ rspl(1)=r(1)
+ espl(1)=epsilonval(1)
+ do i=2,NR
+ if(r(i) /= r(i-1)) then
+ nspl=nspl+1
+ rspl(nspl)=r(i)
+ espl(nspl)=epsilonval(i)
+ endif
+ enddo
+
+! spline epsilonval
+ yp1=0.0d0
+ ypn=(5.0d0/2.0d0)*(bom**2)/g_a-2.0d0*epsilonval(NR)
+ call spline_construction(rspl,espl,nspl,yp1,ypn,espl2)
+
+ end subroutine make_ellipticity
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/make_gravity.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_gravity.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/make_gravity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/make_gravity.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,156 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 make_gravity(nspl,rspl,gspl,gspl2,ONE_CRUST)
+
+! creates a spline for the gravity profile in PREM
+! radius and density are non-dimensional
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspl
+
+ logical ONE_CRUST
+
+! radius of the Earth for gravity calculation
+ double precision, parameter :: R_EARTH_GRAVITY = 6371000.d0
+! radius of the ocean floor for gravity calculation
+ double precision, parameter :: ROCEAN_GRAVITY = 6368000.d0
+
+ double precision rspl(NR),gspl(NR),gspl2(NR)
+
+ integer i
+ double precision ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670, &
+ R771,RTOPDDOUBLEPRIME,RCMB,RICB
+ double precision r_icb,r_cmb,r_topddoubleprime,r_771,r_670,r_600
+ double precision r_400,r_220,r_80,r_moho,r_middle_crust,r_ocean,r_0
+ double precision r(NR),rho(NR),g(NR),i_rho
+ double precision s1(NR),s2(NR),s3(NR)
+ double precision yp1,ypn
+
+! 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
+
+! non-dimensionalize
+ r_icb = RICB/R_EARTH_GRAVITY
+ r_cmb = RCMB/R_EARTH_GRAVITY
+ r_topddoubleprime = RTOPDDOUBLEPRIME/R_EARTH_GRAVITY
+ r_771 = R771/R_EARTH_GRAVITY
+ r_670 = R670/R_EARTH_GRAVITY
+ r_600 = R600/R_EARTH_GRAVITY
+ r_400 = R400/R_EARTH_GRAVITY
+ r_220 = R220/R_EARTH_GRAVITY
+ r_80 = R80/R_EARTH_GRAVITY
+ r_moho = RMOHO/R_EARTH_GRAVITY
+ r_middle_crust = RMIDDLE_CRUST/R_EARTH_GRAVITY
+ r_ocean = ROCEAN_GRAVITY/R_EARTH_GRAVITY
+ r_0 = 1.d0
+
+ do i=1,163
+ r(i) = r_icb*dble(i-1)/dble(162)
+ enddo
+ do i=164,323
+ r(i) = r_icb+(r_cmb-r_icb)*dble(i-164)/dble(159)
+ enddo
+ do i=324,336
+ r(i) = r_cmb+(r_topddoubleprime-r_cmb)*dble(i-324)/dble(12)
+ enddo
+ do i=337,517
+ r(i) = r_topddoubleprime+(r_771-r_topddoubleprime)*dble(i-337)/dble(180)
+ enddo
+ do i=518,530
+ r(i) = r_771+(r_670-r_771)*dble(i-518)/dble(12)
+ enddo
+ do i=531,540
+ r(i) = r_670+(r_600-r_670)*dble(i-531)/dble(9)
+ enddo
+ do i=541,565
+ r(i) = r_600+(r_400-r_600)*dble(i-541)/dble(24)
+ enddo
+ do i=566,590
+ r(i) = r_400+(r_220-r_400)*dble(i-566)/dble(24)
+ enddo
+ do i=591,609
+ r(i) = r_220+(r_80-r_220)*dble(i-591)/dble(18)
+ enddo
+ do i=610,619
+ r(i) = r_80+(r_moho-r_80)*dble(i-610)/dble(9)
+ enddo
+ do i=620,626
+ r(i) = r_moho+(r_middle_crust-r_moho)*dble(i-620)/dble(6)
+ enddo
+ do i=627,633
+ r(i) = r_middle_crust+(r_ocean-r_middle_crust)*dble(i-627)/dble(6)
+ enddo
+ do i=634,NR
+ r(i) = r_ocean+(r_0-r_ocean)*dble(i-634)/dble(6)
+ enddo
+
+! use PREM to get the density profile for ellipticity (fine for other 1D reference models)
+ do i=1,NR
+ call prem_density(r(i),rho(i),ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN_GRAVITY)
+ enddo
+
+ g(1)=0.0d0
+ do i=2,NR
+ call intgrl(i_rho,r,1,i,rho,s1,s2,s3)
+ g(i)=4.0d0*i_rho/(r(i)*r(i))
+ enddo
+
+!
+! get ready to spline g
+!
+ nspl=1
+ rspl(1)=r(1)
+ gspl(1)=g(1)
+ do i=2,NR
+ if(r(i)/=r(i-1)) then
+ nspl=nspl+1
+ rspl(nspl)=r(i)
+ gspl(nspl)=g(i)
+ endif
+ enddo
+ yp1=(4.0d0/3.0d0)*rho(1)
+ ypn=4.0d0*rho(NR)-2.0d0*g(NR)/r(NR)
+ call spline_construction(rspl,gspl,nspl,yp1,ypn,gspl2)
+
+ end subroutine make_gravity
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/mantle_model.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mantle_model.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/mantle_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/mantle_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,457 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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_mantle_model(D3MM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+ integer k,l,m
+
+ character(len=150) S20RTS, P12
+
+ call get_value_string(S20RTS, 'model.S20RTS', 'DATA/s20rts/S20RTS.dat')
+ call get_value_string(P12, 'model.P12', 'DATA/s20rts/P12.dat')
+
+! S20RTS degree 20 S model from Ritsema
+ open(unit=10,file=S20RTS,status='old',action='read')
+ do k=0,NK
+ do l=0,NS
+ read(10,*) D3MM_V%dvs_a(k,l,0),(D3MM_V%dvs_a(k,l,m),D3MM_V%dvs_b(k,l,m),m=1,l)
+ enddo
+ enddo
+ close(10)
+
+! P12 degree 12 P model from Ritsema
+ open(unit=10,file=P12,status='old',action='read')
+ do k=0,NK
+ do l=0,12
+ read(10,*) D3MM_V%dvp_a(k,l,0),(D3MM_V%dvp_a(k,l,m),D3MM_V%dvp_b(k,l,m),m=1,l)
+ enddo
+ do l=13,NS
+ D3MM_V%dvp_a(k,l,0) = 0.0d0
+ do m=1,l
+ D3MM_V%dvp_a(k,l,m) = 0.0d0
+ D3MM_V%dvp_b(k,l,m) = 0.0d0
+ enddo
+ enddo
+ enddo
+ close(10)
+
+! set up the splines used as radial basis functions by Ritsema
+ call splhsetup(D3MM_V)
+
+ end subroutine read_mantle_model
+
+!---------------------------
+
+ subroutine mantle_model(radius,theta,phi,dvs,dvp,drho,D3MM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+! factor to convert perturbations in shear speed to perturbations in density
+ double precision, parameter :: SCALE_RHO = 0.40d0
+
+ double precision radius,theta,phi,dvs,dvp,drho
+
+ double precision, parameter :: RMOHO_ = 6346600.d0
+ double precision, parameter :: RCMB_ = 3480000.d0
+ double precision, parameter :: R_EARTH_ = 6371000.d0
+ double precision, parameter :: ZERO_ = 0.d0
+
+ integer l,m,k
+ double precision r_moho,r_cmb,xr
+ double precision dvs_alm,dvs_blm
+ double precision dvp_alm,dvp_blm
+ double precision rsple,radial_basis(0:NK)
+ double precision sint,cost,x(2*NS+1),dx(2*NS+1)
+
+ dvs = ZERO_
+ dvp = ZERO_
+ drho = ZERO_
+
+ r_moho = RMOHO_ / R_EARTH_
+ r_cmb = RCMB_ / R_EARTH_
+ if(radius>=r_moho .or. radius <= r_cmb) return
+
+ xr=-1.0d0+2.0d0*(radius-r_cmb)/(r_moho-r_cmb)
+ do k=0,NK
+ radial_basis(k)=rsple(1,NK+1,D3MM_V%spknt(1),D3MM_V%qq0(1,NK+1-k),D3MM_V%qq(1,1,NK+1-k),xr)
+ enddo
+
+ do l=0,NS
+ sint=dsin(theta)
+ cost=dcos(theta)
+ call lgndr(l,cost,sint,x,dx)
+ dvs_alm=0.0d0
+ dvp_alm=0.0d0
+ do k=0,NK
+ dvs_alm=dvs_alm+radial_basis(k)*D3MM_V%dvs_a(k,l,0)
+ dvp_alm=dvp_alm+radial_basis(k)*D3MM_V%dvp_a(k,l,0)
+ enddo
+ dvs=dvs+dvs_alm*x(1)
+ dvp=dvp+dvp_alm*x(1)
+ do m=1,l
+ dvs_alm=0.0d0
+ dvp_alm=0.0d0
+ dvs_blm=0.0d0
+ dvp_blm=0.0d0
+ do k=0,NK
+ dvs_alm=dvs_alm+radial_basis(k)*D3MM_V%dvs_a(k,l,m)
+ dvp_alm=dvp_alm+radial_basis(k)*D3MM_V%dvp_a(k,l,m)
+ dvs_blm=dvs_blm+radial_basis(k)*D3MM_V%dvs_b(k,l,m)
+ dvp_blm=dvp_blm+radial_basis(k)*D3MM_V%dvp_b(k,l,m)
+ enddo
+ dvs=dvs+(dvs_alm*dcos(dble(m)*phi)+dvs_blm*dsin(dble(m)*phi))*x(m+1)
+ dvp=dvp+(dvp_alm*dcos(dble(m)*phi)+dvp_blm*dsin(dble(m)*phi))*x(m+1)
+ enddo
+ enddo
+
+ drho = SCALE_RHO*dvs
+
+ end subroutine mantle_model
+
+!----------------------------------
+
+ subroutine splhsetup(D3MM_V)!!!!!!!!!!!!!!(spknt,qq0,qq)
+
+ implicit none
+ include "constants.h"
+
+!!!!!!!!!!!!!!!!!!! double precision spknt(NK+1),qq0(NK+1,NK+1),qq(3,NK+1,NK+1)
+
+! 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
+
+
+ integer i,j
+ double precision qqwk(3,NK+1)
+
+ D3MM_V%spknt(1) = -1.00000d0
+ D3MM_V%spknt(2) = -0.78631d0
+ D3MM_V%spknt(3) = -0.59207d0
+ D3MM_V%spknt(4) = -0.41550d0
+ D3MM_V%spknt(5) = -0.25499d0
+ D3MM_V%spknt(6) = -0.10909d0
+ D3MM_V%spknt(7) = 0.02353d0
+ D3MM_V%spknt(8) = 0.14409d0
+ D3MM_V%spknt(9) = 0.25367d0
+ D3MM_V%spknt(10) = 0.35329d0
+ D3MM_V%spknt(11) = 0.44384d0
+ D3MM_V%spknt(12) = 0.52615d0
+ D3MM_V%spknt(13) = 0.60097d0
+ D3MM_V%spknt(14) = 0.66899d0
+ D3MM_V%spknt(15) = 0.73081d0
+ D3MM_V%spknt(16) = 0.78701d0
+ D3MM_V%spknt(17) = 0.83810d0
+ D3MM_V%spknt(18) = 0.88454d0
+ D3MM_V%spknt(19) = 0.92675d0
+ D3MM_V%spknt(20) = 0.96512d0
+ D3MM_V%spknt(21) = 1.00000d0
+
+ do i=1,NK+1
+ do j=1,NK+1
+ if(i == j) then
+ D3MM_V%qq0(j,i)=1.0d0
+ else
+ D3MM_V%qq0(j,i)=0.0d0
+ endif
+ enddo
+ enddo
+ do i=1,NK+1
+ call rspln(1,NK+1,D3MM_V%spknt(1),D3MM_V%qq0(1,i),D3MM_V%qq(1,1,i),qqwk(1,1))
+ enddo
+
+ end subroutine splhsetup
+
+!----------------------------------
+
+! changed the obsolecent f77 features in the two routines below
+! now still awful Fortran, but at least conforms to f90 standard
+
+ double precision function rsple(I1,I2,X,Y,Q,S)
+
+ implicit none
+
+! rsple returns the value of the function y(x) evaluated at point S
+! using the cubic spline coefficients computed by rspln and saved in Q.
+! If S is outside the interval (x(i1),x(i2)) rsple extrapolates
+! using the first or last interpolation polynomial. The arrays must
+! be dimensioned at least - x(i2), y(i2), and q(3,i2).
+
+ integer i1,i2
+ double precision X(*),Y(*),Q(3,*),s
+
+ integer i,ii
+ double precision h
+
+ i = 1
+ II=I2-1
+
+! GUARANTEE I WITHIN BOUNDS.
+ I=MAX0(I,I1)
+ I=MIN0(I,II)
+
+! SEE IF X IS INCREASING OR DECREASING.
+ IF(X(I2)-X(I1) < 0) goto 1
+ IF(X(I2)-X(I1) >= 0) goto 2
+
+! X IS DECREASING. CHANGE I AS NECESSARY.
+ 1 IF(S-X(I) <= 0) goto 3
+ IF(S-X(I) > 0) goto 4
+
+ 4 I=I-1
+
+ IF(I-I1 < 0) goto 11
+ IF(I-I1 == 0) goto 6
+ IF(I-I1 > 0) goto 1
+
+ 3 IF(S-X(I+1) < 0) goto 5
+ IF(S-X(I+1) >= 0) goto 6
+
+ 5 I=I+1
+
+ IF(I-II < 0) goto 3
+ IF(I-II == 0) goto 6
+ IF(I-II > 0) goto 7
+
+! X IS INCREASING. CHANGE I AS NECESSARY.
+ 2 IF(S-X(I+1) <= 0) goto 8
+ IF(S-X(I+1) > 0) goto 9
+
+ 9 I=I+1
+
+ IF(I-II < 0) goto 2
+ IF(I-II == 0) goto 6
+ IF(I-II > 0) goto 7
+
+ 8 IF(S-X(I) < 0) goto 10
+ IF(S-X(I) >= 0) goto 6
+
+ 10 I=I-1
+ IF(I-I1 < 0) goto 11
+ IF(I-I1 == 0) goto 6
+ IF(I-I1 > 0) goto 8
+
+ 7 I=II
+ GOTO 6
+ 11 I=I1
+
+! CALCULATE RSPLE USING SPLINE COEFFICIENTS IN Y AND Q.
+ 6 H=S-X(I)
+ RSPLE=Y(I)+H*(Q(1,I)+H*(Q(2,I)+H*Q(3,I)))
+
+ end function rsple
+
+!----------------------------------
+
+ subroutine rspln(I1,I2,X,Y,Q,F)
+
+ implicit none
+
+! Subroutine rspln computes cubic spline interpolation coefficients
+! for y(x) between grid points i1 and i2 saving them in q.The
+! interpolation is continuous with continuous first and second
+! derivatives. It agrees exactly with y at grid points and with the
+! three point first derivatives at both end points (i1 and i2).
+! X must be monotonic but if two successive values of x are equal
+! a discontinuity is assumed and separate interpolation is done on
+! each strictly monotonic segment. The arrays must be dimensioned at
+! least - x(i2), y(i2), q(3,i2), and f(3,i2).
+! F is working storage for rspln.
+
+ integer i1,i2
+ double precision X(*),Y(*),Q(3,*),F(3,*)
+
+ integer i,j,k,j1,j2
+ double precision y0,a0,b0,b1,h,h2,ha,h2a,h3a,h2b
+ double precision YY(3),small
+ equivalence (YY(1),Y0)
+ data SMALL/1.0d-08/,YY/0.0d0,0.0d0,0.0d0/
+
+ J1=I1+1
+ Y0=0.0d0
+
+! BAIL OUT IF THERE ARE LESS THAN TWO POINTS TOTAL
+ IF(I2-I1 < 0) return
+ IF(I2-I1 == 0) goto 17
+ IF(I2-I1 > 0) goto 8
+
+ 8 A0=X(J1-1)
+! SEARCH FOR DISCONTINUITIES.
+ DO 3 I=J1,I2
+ B0=A0
+ A0=X(I)
+ IF(DABS((A0-B0)/DMAX1(A0,B0)) < SMALL) GOTO 4
+ 3 CONTINUE
+ 17 J1=J1-1
+ J2=I2-2
+ GOTO 5
+ 4 J1=J1-1
+ J2=I-3
+! SEE IF THERE ARE ENOUGH POINTS TO INTERPOLATE (AT LEAST THREE).
+ 5 IF(J2+1-J1 < 0) goto 9
+ IF(J2+1-J1 == 0) goto 10
+ IF(J2+1-J1 > 0) goto 11
+
+! ONLY TWO POINTS. USE LINEAR INTERPOLATION.
+ 10 J2=J2+2
+ Y0=(Y(J2)-Y(J1))/(X(J2)-X(J1))
+ DO J=1,3
+ Q(J,J1)=YY(J)
+ Q(J,J2)=YY(J)
+ enddo
+ GOTO 12
+
+! MORE THAN TWO POINTS. DO SPLINE INTERPOLATION.
+ 11 A0=0.
+ H=X(J1+1)-X(J1)
+ H2=X(J1+2)-X(J1)
+ Y0=H*H2*(H2-H)
+ H=H*H
+ H2=H2*H2
+! CALCULATE DERIVITIVE AT NEAR END.
+ B0=(Y(J1)*(H-H2)+Y(J1+1)*H2-Y(J1+2)*H)/Y0
+ B1=B0
+
+! EXPLICITLY REDUCE BANDED MATRIX TO AN UPPER BANDED MATRIX.
+ DO I=J1,J2
+ H=X(I+1)-X(I)
+ Y0=Y(I+1)-Y(I)
+ H2=H*H
+ HA=H-A0
+ H2A=H-2.0d0*A0
+ H3A=2.0d0*H-3.0d0*A0
+ H2B=H2*B0
+ Q(1,I)=H2/HA
+ Q(2,I)=-HA/(H2A*H2)
+ Q(3,I)=-H*H2A/H3A
+ F(1,I)=(Y0-H*B0)/(H*HA)
+ F(2,I)=(H2B-Y0*(2.0d0*H-A0))/(H*H2*H2A)
+ F(3,I)=-(H2B-3.0d0*Y0*HA)/(H*H3A)
+ A0=Q(3,I)
+ B0=F(3,I)
+ enddo
+
+! TAKE CARE OF LAST TWO ROWS.
+ I=J2+1
+ H=X(I+1)-X(I)
+ Y0=Y(I+1)-Y(I)
+ H2=H*H
+ HA=H-A0
+ H2A=H*HA
+ H2B=H2*B0-Y0*(2.0d0*H-A0)
+ Q(1,I)=H2/HA
+ F(1,I)=(Y0-H*B0)/H2A
+ HA=X(J2)-X(I+1)
+ Y0=-H*HA*(HA+H)
+ HA=HA*HA
+
+! CALCULATE DERIVATIVE AT FAR END.
+ Y0=(Y(I+1)*(H2-HA)+Y(I)*HA-Y(J2)*H2)/Y0
+ Q(3,I)=(Y0*H2A+H2B)/(H*H2*(H-2.0d0*A0))
+ Q(2,I)=F(1,I)-Q(1,I)*Q(3,I)
+
+! SOLVE UPPER BANDED MATRIX BY REVERSE ITERATION.
+ DO J=J1,J2
+ K=I-1
+ Q(1,I)=F(3,K)-Q(3,K)*Q(2,I)
+ Q(3,K)=F(2,K)-Q(2,K)*Q(1,I)
+ Q(2,K)=F(1,K)-Q(1,K)*Q(3,K)
+ I=K
+ enddo
+ Q(1,I)=B1
+! FILL IN THE LAST POINT WITH A LINEAR EXTRAPOLATION.
+ 9 J2=J2+2
+ DO J=1,3
+ Q(J,J2)=YY(J)
+ enddo
+
+! SEE IF THIS DISCONTINUITY IS THE LAST.
+ 12 IF(J2-I2 < 0) then
+ goto 6
+ else
+ return
+ endif
+
+! NO. GO BACK FOR MORE.
+ 6 J1=J2+2
+ IF(J1-I2 <= 0) goto 8
+ IF(J1-I2 > 0) goto 7
+
+! THERE IS ONLY ONE POINT LEFT AFTER THE LATEST DISCONTINUITY.
+ 7 DO J=1,3
+ Q(J,I2)=YY(J)
+ enddo
+
+ end subroutine rspln
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/memory_eval.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/memory_eval.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/memory_eval.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/memory_eval.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,351 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! compute the approximate amount of static memory needed to run the solver
+
+ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+ ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+ ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+ NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+ implicit none
+
+ include "constants.h"
+
+! input
+ logical, intent(in) :: TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ROTATION,ATTENUATION,ONE_CRUST,OCEANS,ABSORBING_CONDITIONS,MOVIE_VOLUME,SAVE_FORWARD
+ integer, dimension(MAX_NUM_REGIONS), intent(in) :: NSPEC, nglob
+ integer, intent(in) :: NEX_PER_PROC_XI,NEX_PER_PROC_ETA,SIMULATION_TYPE
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: doubling_index
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: this_region_has_a_doubling
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: ner,ratio_sampling_array
+
+! output
+ double precision, intent(out) :: static_memory_size
+
+! variables
+ integer :: ilayer,NUMBER_OF_MESH_LAYERS,ner_without_doubling,ispec_aniso
+
+ integer, intent(out) :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
+
+! generate the elements in all the regions of the mesh
+ ispec_aniso = 0
+
+ if (ONE_CRUST) then
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS - 1
+ else
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS
+ endif
+
+! count anisotropic elements
+ do ilayer = 1, NUMBER_OF_MESH_LAYERS
+ if(doubling_index(ilayer) == IFLAG_220_80 .or. doubling_index(ilayer) == IFLAG_80_MOHO) then
+ ner_without_doubling = ner(ilayer)
+ if(this_region_has_a_doubling(ilayer)) then
+ ner_without_doubling = ner_without_doubling - 2
+ ispec_aniso = ispec_aniso + &
+ (NSPEC_DOUBLING_SUPERBRICK*(NEX_PER_PROC_XI/ratio_sampling_array(ilayer)/2)* &
+ (NEX_PER_PROC_ETA/ratio_sampling_array(ilayer)/2))
+ endif
+ ispec_aniso = ispec_aniso + &
+ ((NEX_PER_PROC_XI/ratio_sampling_array(ilayer))*(NEX_PER_PROC_ETA/ratio_sampling_array(ilayer))*ner_without_doubling)
+ endif
+ enddo
+
+! define static size of the arrays whose size depends on logical tests
+
+ if(ANISOTROPIC_INNER_CORE) then
+ NSPECMAX_ANISO_IC = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPECMAX_ANISO_IC = 1
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE) then
+ NSPECMAX_ISO_MANTLE = 1
+ NSPECMAX_TISO_MANTLE = 1
+ NSPECMAX_ANISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
+ else
+
+ NSPECMAX_ISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
+ if(TRANSVERSE_ISOTROPY) then
+ NSPECMAX_TISO_MANTLE = ispec_aniso
+ else
+ NSPECMAX_TISO_MANTLE = 1
+ endif
+
+ NSPECMAX_ANISO_MANTLE = 1
+ endif
+
+! if attenuation is off, set dummy size of arrays to one
+ if(ATTENUATION) then
+ NSPEC_CRUST_MANTLE_ATTENUAT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_ATTENUATION = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_ATTENUAT = 1
+ NSPEC_INNER_CORE_ATTENUATION = 1
+ endif
+
+ if(ATTENUATION .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
+ NSPEC_CRUST_MANTLE_STR_OR_ATT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_STR_OR_ATT = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STR_OR_ATT = 1
+ NSPEC_INNER_CORE_STR_OR_ATT = 1
+ endif
+
+ if(ATTENUATION .and. SIMULATION_TYPE == 3) then
+ NSPEC_CRUST_MANTLE_STR_AND_ATT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_STR_AND_ATT = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STR_AND_ATT = 1
+ NSPEC_INNER_CORE_STR_AND_ATT = 1
+ endif
+
+
+ if(SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_STRAIN_ONLY = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY = 1
+ NSPEC_INNER_CORE_STRAIN_ONLY = 1
+ endif
+
+ if ((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then
+ NSPEC_CRUST_MANTLE_ADJOINT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_OUTER_CORE_ADJOINT = NSPEC(IREGION_OUTER_CORE)
+ NSPEC_INNER_CORE_ADJOINT = NSPEC(IREGION_INNER_CORE)
+
+ NGLOB_CRUST_MANTLE_ADJOINT = NGLOB(IREGION_CRUST_MANTLE)
+ NGLOB_OUTER_CORE_ADJOINT = NGLOB(IREGION_OUTER_CORE)
+ NGLOB_INNER_CORE_ADJOINT = NGLOB(IREGION_INNER_CORE)
+
+ if(ROTATION) then
+ NSPEC_OUTER_CORE_ROT_ADJOINT = NSPEC(IREGION_OUTER_CORE)
+ else
+ NSPEC_OUTER_CORE_ROT_ADJOINT = 1
+ endif
+ else
+ NSPEC_CRUST_MANTLE_ADJOINT = 1
+ NSPEC_OUTER_CORE_ADJOINT = 1
+ NSPEC_INNER_CORE_ADJOINT = 1
+
+ NGLOB_CRUST_MANTLE_ADJOINT = 1
+ NGLOB_OUTER_CORE_ADJOINT = 1
+ NGLOB_INNER_CORE_ADJOINT = 1
+
+ NSPEC_OUTER_CORE_ROT_ADJOINT = 1
+ endif
+
+! if absorbing conditions are off, set dummy size of arrays to one
+ if(ABSORBING_CONDITIONS) then
+ NSPEC_CRUST_MANTLE_STACEY = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_OUTER_CORE_STACEY = NSPEC(IREGION_OUTER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STACEY = 1
+ NSPEC_OUTER_CORE_STACEY = 1
+ endif
+
+! if oceans are off, set dummy size of arrays to one
+ if(OCEANS) then
+ NGLOB_CRUST_MANTLE_OCEANS = NGLOB(IREGION_CRUST_MANTLE)
+ else
+ NGLOB_CRUST_MANTLE_OCEANS = 1
+ endif
+
+ if(ROTATION) then
+ NSPEC_OUTER_CORE_ROTATION = NSPEC(IREGION_OUTER_CORE)
+ else
+ NSPEC_OUTER_CORE_ROTATION = 1
+ endif
+
+! add size of each set of static arrays multiplied by the number of such arrays
+
+ static_memory_size = 0.d0
+
+! R_memory_crust_mantle
+ static_memory_size = static_memory_size + 5.d0*dble(N_SLS)*dble(NGLLX)* &
+ dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ATTENUAT*dble(CUSTOM_REAL)
+
+! R_memory_inner_core
+ static_memory_size = static_memory_size + 5.d0*dble(N_SLS)*dble(NGLLX)* &
+ dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ATTENUATION*dble(CUSTOM_REAL)
+
+! 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
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*9.d0*dble(CUSTOM_REAL)
+
+! ibool_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*dble(SIZE_INTEGER)
+
+! 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
+! kappavstore_outer_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*10.d0*dble(CUSTOM_REAL)
+
+! ibool_outer_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*dble(SIZE_INTEGER)
+
+! idoubling_crust_mantle
+ static_memory_size = static_memory_size + NSPEC(IREGION_CRUST_MANTLE)*dble(SIZE_INTEGER)
+
+! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,rmass_crust_mantle
+ static_memory_size = static_memory_size + NGLOB(IREGION_CRUST_MANTLE)*4.d0*dble(CUSTOM_REAL)
+
+! kappavstore_crust_mantle,muvstore_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ISO_MANTLE*2.d0*dble(CUSTOM_REAL)
+
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_TISO_MANTLE*3.d0*dble(CUSTOM_REAL)
+
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle,
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle,
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle,
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle,
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle,
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ANISO_MANTLE*21.d0*dble(CUSTOM_REAL)
+
+! displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
+ static_memory_size = static_memory_size + dble(NDIM)*NGLOB(IREGION_CRUST_MANTLE)*3.d0*dble(CUSTOM_REAL)
+
+! xstore_outer_core, ystore_outer_core, zstore_outer_core, rmass_outer_core, displ_outer_core, veloc_outer_core, accel_outer_core
+ static_memory_size = static_memory_size + NGLOB(IREGION_OUTER_CORE)*7.d0*dble(CUSTOM_REAL)
+
+! ibool_inner_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_INNER_CORE)*dble(SIZE_INTEGER)
+
+! 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
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_INNER_CORE)*11.d0*dble(CUSTOM_REAL)
+
+! xstore_inner_core,ystore_inner_core,zstore_inner_core,rmass_inner_core
+ static_memory_size = static_memory_size + NGLOB(IREGION_INNER_CORE)*4.d0*dble(CUSTOM_REAL)
+
+! c11store_inner_core,c33store_inner_core,c12store_inner_core,c13store_inner_core,c44store_inner_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ANISO_IC*5.d0*dble(CUSTOM_REAL)
+
+! displ_inner_core,veloc_inner_core,accel_inner_core
+ static_memory_size = static_memory_size + dble(NDIM)*NGLOB(IREGION_INNER_CORE)*3.d0*dble(CUSTOM_REAL)
+
+! A_array_rotation,B_array_rotation
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ROTATION*2.d0*dble(CUSTOM_REAL)
+
+ if(ABSORBING_CONDITIONS) then
+
+! rho_vp_crust_mantle,rho_vs_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*2.d0*dble(CUSTOM_REAL)
+
+! vp_outer_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*dble(CUSTOM_REAL)
+
+ endif
+
+ if(OCEANS) then
+
+! rmass_ocean_load
+ static_memory_size = static_memory_size + NGLOB(IREGION_CRUST_MANTLE)*dble(CUSTOM_REAL)
+
+ endif
+
+! add arrays used to save strain for attenuation or for adjoint runs
+
+! epsilondev_crust_mantle
+ static_memory_size = static_memory_size + 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
+
+! eps_trace_over_3_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
+
+! epsilondev_inner_core
+ static_memory_size = static_memory_size + 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
+
+! eps_trace_over_3_inner_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
+
+! add arrays used for adjoint runs only (LQY: not very accurate)
+
+! b_R_memory_crust_mantle
+! b_epsilondev_crust_mantle
+! b_eps_trace_over_3_crust_mantle
+! rho_kl_crust_mantle,beta_kl_crust_mantle, alpha_kl_crust_mantle
+ static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 9.d0)* &
+ dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_div_displ_outer_core
+! rho_kl_outer_core,alpha_kl_outer_core
+ static_memory_size = static_memory_size + 3.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_R_memory_inner_core
+! b_epsilondev_inner_core
+! b_eps_trace_over_3_inner_core
+! rho_kl_inner_core,beta_kl_inner_core, alpha_kl_inner_core
+ static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 9.d0)* &
+ dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
+ static_memory_size = static_memory_size + 3.d0*dble(NDIM)*NGLOB_CRUST_MANTLE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
+ static_memory_size = static_memory_size + 3.d0*NGLOB_OUTER_CORE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
+ static_memory_size = static_memory_size + 3.d0*dble(NDIM)*NGLOB_INNER_CORE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_A_array_rotation,b_B_array_rotation
+ static_memory_size = static_memory_size + 2.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ROT_ADJOINT*dble(CUSTOM_REAL)
+
+ end subroutine memory_eval
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,2150 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 Government Sponsorship Acknowledged.
+
+ program xmeshfem3D
+
+ 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 "OUTPUT_FILES/values_from_mesher.h"
+
+!=====================================================================!
+! !
+! 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. !
+! !
+!=====================================================================!
+!
+! 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 caltech.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+! Evolution of the code:
+! ---------------------
+!
+! 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, seismos can be
+! written by the master
+! v. 3.6 Many people, many affiliations, September 2006:
+! adjoint and kernel calculations, 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
+! 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, 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 CM5
+!
+
+! 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(:), pointer :: 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_aniso,npointot
+
+! parameters needed to store the radii of the grid points
+! in the spherically symmetric Earth
+!! DK DK suppressed this for merged version
+! integer, dimension(:), allocatable :: idoubling
+! integer, dimension(:,:,:,:), allocatable :: ibool
+
+! arrays with the mesh in double precision
+ double precision, dimension(:,:,:,:), allocatable :: xstore,ystore,zstore
+
+! proc numbers for MPI
+ integer myrank,sizeprocs,ier,errorcode
+
+! 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
+ integer, dimension(:), allocatable :: ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta
+ double precision, dimension(:), allocatable :: xread1D_leftxi_lefteta,xread1D_rightxi_lefteta, &
+ xread1D_leftxi_righteta,xread1D_rightxi_righteta
+ double precision, dimension(:), allocatable :: yread1D_leftxi_lefteta,yread1D_rightxi_lefteta, &
+ yread1D_leftxi_righteta,yread1D_rightxi_righteta
+ double precision, dimension(:), allocatable :: 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(:), allocatable :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
+ integer, dimension(:,:,:), allocatable :: 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
+
+ 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,LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, 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
+
+! DK DK UGLY if running on MareNostrum in Barcelona
+ integer :: sender, receiver, dummy1, dummy2
+ integer msg_status(MPI_STATUS_SIZE)
+ character(len=400) system_command
+
+! computed in read_compute_parameters
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! memory size of all the static arrays
+! double precision :: static_memory_size
+
+! arrays for BCAST
+ integer, dimension(38) :: 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)
+
+ integer :: ipass
+
+!! DK DK suppressed this for the merged version
+! integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+! NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+! NSPEC_INNER_CORE_ATTENUATION, &
+! NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+! NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+! NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+! NSPEC_CRUST_MANTLE_ADJOINT, &
+! NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+! NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+! NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+! NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+! NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
+
+! 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
+! integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
+
+!! DK DK for the merged version
+ include 'declar.f90'
+
+!! DK DK added this for the merged version
+!---- arrays to assemble between chunks
+
+ integer :: imsg
+
+! 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
+
+ logical :: not_done_yet
+
+! ************** PROGRAM STARTS HERE **************
+
+! initialize the MPI communicator and start the NPROCTOT MPI processes.
+ call MPI_INIT(ier)
+
+! 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)
+
+! 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')
+
+! 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,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
+
+ if(err_occurred() /= 0) then
+ call exit_MPI(myrank,'an error occurred while reading the parameter file')
+ endif
+
+! 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/)
+
+ 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(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_integer,38,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(LOCAL_PATH,150,MPI_CHARACTER,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_region_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)
+
+ 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
+
+! DK DK UGLY if running on MareNostrum in Barcelona
+ if(RUN_ON_MARENOSTRUM_BARCELONA) then
+
+! check that we combine the seismograms in one large file to avoid GPFS overloading
+ if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) call exit_MPI(myrank,'should use SAVE_ALL_SEISMOS_IN_ONE_FILE for GPFS in Barcelona')
+
+! clean the local scratch space using a cascade (serial removal, one process after the other)
+ if(myrank == 0) then
+
+ receiver = myrank + 1
+ call system('rm -f -r /scratch/komatits_new* > /dev/null')
+ call MPI_SEND(dummy1,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
+
+ else
+
+ sender = myrank - 1
+ receiver = myrank + 1
+ call MPI_RECV(dummy2,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ call system('rm -f -r /scratch/komatits_new* > /dev/null')
+ if(myrank < sizeprocs - 1) call MPI_SEND(dummy1,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif
+
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! use the local scratch disk to save all the files, ignore the path that is given in the Par_file
+ LOCAL_PATH = '/scratch/komatits_new'
+
+! add processor name to local /scratch/komatits_new path
+ write(system_command,"('_proc',i4.4)") myrank
+ LOCAL_PATH = trim(LOCAL_PATH) // trim(system_command)
+
+! create a local directory to store all the local files
+ write(system_command,"('mkdir /scratch/komatits_new_proc',i4.4)") myrank
+ call system(system_command)
+
+ 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')
+
+! dynamic allocation of mesh arrays
+ allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(ichunk_slice(0:NPROCTOT-1),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(iproc_xi_slice(0:NPROCTOT-1),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(iproc_eta_slice(0:NPROCTOT-1),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ 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
+!! DK DK suppressed this for merged
+!! DK DK suppressed this for merged open(unit=IOUT,file=trim(OUTPUT_FILES)//'/addressing.txt',status='unknown')
+ 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
+!! DK DK suppressed this for merged
+!! DK DK suppressed this for merged if(myrank == 0) write(IOUT,*) iprocnum,ichunk,iproc_xi,iproc_eta
+ enddo
+ enddo
+ enddo
+!! DK DK suppressed this for merged
+!! DK DK suppressed this for merged if(myrank == 0) close(IOUT)
+
+!! DK DK added this for the merged version
+ not_done_yet = .true.
+
+! 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)
+
+ if(myrank /= 0) then
+ allocate(AM_V%Qtau_s(N_SLS),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ endif
+ 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
+
+! make sure everybody is synchronized
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+!----
+!---- loop on all the regions of the mesh
+!----
+
+!! DK DK for the merged version
+ include 'allocate_before.f90'
+
+!! DK DK for the merged version
+ allocate(ibool1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(ibool1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(ibool1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(ibool1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xread1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(xread1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(xread1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(xread1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(yread1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(yread1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(yread1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(yread1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(zread1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(zread1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(zread1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(zread1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! 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
+
+! use dynamic allocation to allocate memory for arrays
+!! DK DK suppressed this for merged version
+! allocate(idoubling(NSPEC(iregion_code)),STAT=ier)
+! allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
+ allocate(xstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(ystore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(zstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! create all the regions of the mesh
+! perform two passes in this part to be able to save memory
+ do ipass = 1,2
+
+!! 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_aniso, &
+ 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, &
+ max(NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
+ myrank,LOCAL_PATH,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_region_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,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
+ 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),perm,invperm)
+
+ 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_aniso, &
+ 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, &
+ max(NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
+ myrank,LOCAL_PATH,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_region_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,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
+ 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),perm,invperm)
+
+ 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_aniso, &
+ 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, &
+ max(NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
+ myrank,LOCAL_PATH,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_region_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,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
+ 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),perm,invperm)
+
+ else
+ stop 'DK DK incorrect region in merged code'
+ endif
+
+ enddo ! of loop on ipass = 1,2
+
+! store number of anisotropic elements found in the mantle
+ if(nspec_aniso /= 0 .and. iregion_code /= IREGION_CRUST_MANTLE) &
+ call exit_MPI(myrank,'found anisotropic elements outside of the mantle')
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. nspec_aniso == 0) &
+ call exit_MPI(myrank,'found no anisotropic elements in the mantle')
+
+! use MPI reduction to compute total area and volume
+ 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
+
+!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+!! DK DK added this for merged version
+
+! create the list of messages in files to assemble between chunks if more than one chunk
+! create it only once (and for all) therefore for first region only, because stored in disk files
+!! DK DK this could probably be simplified or merged with create_chunk_buffers, but no time to do it for now
+ if(NCHUNKS > 1 .and. iregion_code == IREGION_CRUST_MANTLE) &
+! crust_mantle
+ call create_list_files_chunks(iregion_code, &
+ nglob(iregion_code),NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_CORNER, &
+ myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS)
+
+!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+!! DK DK added this for merged version
+
+! read chunk messages only if more than one chunk
+ if(NCHUNKS_VAL /= 1 .and. myrank == 0 .and. not_done_yet) then
+
+! do this only once in the mesher, because these arrays do not change
+ not_done_yet = .false.
+
+! read messages to assemble between chunks with MPI
+
+! file with the list of processors for each message for faces
+ open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='old',action='read')
+ do imsg = 1,NUMMSGS_FACES_VAL
+ read(IIN,*) imsg_type(imsg),iprocfrom_faces(imsg),iprocto_faces(imsg)
+ if (iprocfrom_faces(imsg) < 0 &
+ .or. iprocto_faces(imsg) < 0 &
+ .or. iprocfrom_faces(imsg) > NPROCTOT-1 &
+ .or. iprocto_faces(imsg) > NPROCTOT-1) &
+ call exit_MPI(myrank,'incorrect chunk faces numbering')
+ if (imsg_type(imsg) < 1 .or. imsg_type(imsg) > 3) &
+ call exit_MPI(myrank,'incorrect message type labeling')
+ enddo
+ close(IIN)
+
+! file with the list of processors for each message for corners
+ open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='old',action='read')
+ do imsg = 1,NCORNERSCHUNKS_VAL
+ read(IIN,*) iproc_master_corners(imsg),iproc_worker1_corners(imsg), &
+ iproc_worker2_corners(imsg)
+ if (iproc_master_corners(imsg) < 0 &
+ .or. iproc_worker1_corners(imsg) < 0 &
+ .or. iproc_worker2_corners(imsg) < 0 &
+ .or. iproc_master_corners(imsg) > NPROCTOT-1 &
+ .or. iproc_worker1_corners(imsg) > NPROCTOT-1 &
+ .or. iproc_worker2_corners(imsg) > NPROCTOT-1) &
+ call exit_MPI(myrank,'incorrect chunk corner numbering')
+ enddo
+ close(IIN)
+
+ endif
+
+! broadcast the information read on the master to the nodes
+ if(NCHUNKS_VAL /= 1) then
+ call MPI_BCAST(imsg_type,NUMMSGS_FACES_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iprocfrom_faces,NUMMSGS_FACES_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iprocto_faces,NUMMSGS_FACES_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(iproc_master_corners,NCORNERSCHUNKS_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iproc_worker1_corners,NCORNERSCHUNKS_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iproc_worker2_corners,NCORNERSCHUNKS_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ 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,LOCAL_PATH,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,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,LOCAL_PATH,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,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,LOCAL_PATH,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,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
+
+! deallocate arrays used for that region
+!! DK DK suppressed this for merged version
+! deallocate(idoubling)
+! deallocate(ibool)
+ deallocate(xstore)
+ deallocate(ystore)
+ deallocate(zstore)
+
+! make sure everybody is synchronized
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! end of loop on all the regions
+ enddo
+
+!! DK DK for the merged version
+ deallocate(ibool1D_leftxi_lefteta)
+ deallocate(ibool1D_rightxi_lefteta)
+ deallocate(ibool1D_leftxi_righteta)
+ deallocate(ibool1D_rightxi_righteta)
+
+ deallocate(xread1D_leftxi_lefteta)
+ deallocate(xread1D_rightxi_lefteta)
+ deallocate(xread1D_leftxi_righteta)
+ deallocate(xread1D_rightxi_righteta)
+
+ deallocate(yread1D_leftxi_lefteta)
+ deallocate(yread1D_rightxi_lefteta)
+ deallocate(yread1D_leftxi_righteta)
+ deallocate(yread1D_rightxi_righteta)
+
+ deallocate(zread1D_leftxi_lefteta)
+ deallocate(zread1D_rightxi_lefteta)
+ deallocate(zread1D_leftxi_righteta)
+ deallocate(zread1D_rightxi_righteta)
+
+ 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,*)
+
+! evaluate the amount of static memory needed by the solver
+!! DK DK suppressed in the merged version because useless
+! call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+! TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+! ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+! ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+! NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+! NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+! NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+! NSPEC_INNER_CORE_ATTENUATION, &
+! NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+! NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+! NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+! NSPEC_CRUST_MANTLE_ADJOINT, &
+! NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+! NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+! NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+! NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+! NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+!! DK DK suppressed in the merged version because useless
+! NGLOB1D_RADIAL_TEMP(:) = &
+! (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
+
+! create include file for the solver
+!! DK DK suppressed in the merged version because useless
+! call save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
+! TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+! ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
+! ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
+! INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP, &
+! static_memory_size,NGLOB1D_RADIAL_TEMP, &
+! NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+! NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
+! NPROC_XI,NPROC_ETA, &
+! NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+! NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+! NSPEC_INNER_CORE_ATTENUATION, &
+! NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+! NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+! NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+! NSPEC_CRUST_MANTLE_ADJOINT, &
+! NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+! NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+! NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+! NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+! NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
+
+ endif ! end of section executed by main process only
+
+! deallocate arrays used for mesh generation
+!! DK DK suppressed in the merged version because these arrays will be transmitted to the solver
+! deallocate(addressing)
+! deallocate(ichunk_slice)
+! deallocate(iproc_xi_slice)
+! deallocate(iproc_eta_slice)
+
+! 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
+
+! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+!!!!!!!! DK DK solver inserted here
+!!!!!!!! DK DK solver inserted here
+!!!!!!!! DK DK solver inserted here
+
+!! 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 for the merged version
+ include 'allocate_after_1.f90'
+
+!! 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)
+
+ 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)
+
+ 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)
+
+!! 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)
+
+!! DK DK for the merged version
+ include 'allocate_after_2.f90'
+
+!! DK DK for the merged version
+ include 'call1.f90'
+!! DK DK for now use variables just to make sure we don't get warning about unused variables
+! include 'oldstuff/dummy_use_variables.f90'
+
+!! DK DK for the merged version
+ include 'deallocate.f90'
+
+!!!!!!!! DK DK solver inserted here
+!!!!!!!! DK DK solver inserted here
+!!!!!!!! DK DK solver inserted here
+
+! 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 xmeshfem3D
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_1066a.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_1066a.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_1066a.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_1066a.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,1131 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 model_1066a(x,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V)
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+! input:
+! radius r: meters
+
+! output:
+! density rho: kg/m^3
+! compressional wave speed vp: km/s
+! shear wave speed vs: km/s
+
+ integer iregion_code
+
+ double precision x,rho,vp,vs,Qmu,Qkappa
+
+ integer i
+
+ double precision r,frac,scaleval
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+ i = 1
+ do while(r >= M1066a_V%radius_1066a(i) .and. i /= NR_1066A)
+ i = i + 1
+ enddo
+
+! make sure we stay in the right region and never take a point above
+! and a point below the ICB or the CMB and interpolate between them,
+! which would lead to a wrong value (keeping in mind that we interpolate
+! between points i-1 and i below)
+ if(iregion_code == IREGION_INNER_CORE .and. i > 33) i = 33
+
+ if(iregion_code == IREGION_OUTER_CORE .and. i < 35) i = 35
+ if(iregion_code == IREGION_OUTER_CORE .and. i > 66) i = 66
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. i < 68) i = 68
+
+ if(i == 1) then
+ rho = M1066a_V%density_1066a(i)
+ vp = M1066a_V%vp_1066a(i)
+ vs = M1066a_V%vs_1066a(i)
+ Qmu = M1066a_V%Qmu_1066a(i)
+ Qkappa = M1066a_V%Qkappa_1066a(i)
+ else
+
+! interpolate from radius_1066a(i-1) to r using the values at i-1 and i
+ frac = (r-M1066a_V%radius_1066a(i-1))/(M1066a_V%radius_1066a(i)-M1066a_V%radius_1066a(i-1))
+
+ rho = M1066a_V%density_1066a(i-1) + frac * (M1066a_V%density_1066a(i)-M1066a_V%density_1066a(i-1))
+ vp = M1066a_V%vp_1066a(i-1) + frac * (M1066a_V%vp_1066a(i)-M1066a_V%vp_1066a(i-1))
+ vs = M1066a_V%vs_1066a(i-1) + frac * (M1066a_V%vs_1066a(i)-M1066a_V%vs_1066a(i-1))
+ Qmu = M1066a_V%Qmu_1066a(i-1) + frac * (M1066a_V%Qmu_1066a(i)-M1066a_V%Qmu_1066a(i-1))
+ Qkappa = M1066a_V%Qkappa_1066a(i-1) + frac * (M1066a_V%Qkappa_1066a(i)-M1066a_V%Qkappa_1066a(i-1))
+
+ endif
+
+! make sure Vs is zero in the outer core even if roundoff errors on depth
+! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
+ if(iregion_code == IREGION_OUTER_CORE) then
+ vs = 0.d0
+ Qkappa = 3000.d0
+ Qmu = 3000.d0
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine model_1066a
+
+!-------------------
+
+ subroutine define_model_1066a(USE_EXTERNAL_CRUSTAL_MODEL,M1066a_V)
+
+ implicit none
+ include "constants.h"
+
+! 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
+
+ logical USE_EXTERNAL_CRUSTAL_MODEL
+
+ integer i
+
+! define all the values in the model
+
+ M1066a_V%radius_1066a( 1) = 0.000000000000000
+ M1066a_V%radius_1066a( 2) = 38400.0000000000
+ M1066a_V%radius_1066a( 3) = 76810.0000000000
+ M1066a_V%radius_1066a( 4) = 115210.000000000
+ M1066a_V%radius_1066a( 5) = 153610.000000000
+ M1066a_V%radius_1066a( 6) = 192020.000000000
+ M1066a_V%radius_1066a( 7) = 230420.000000000
+ M1066a_V%radius_1066a( 8) = 268820.000000000
+ M1066a_V%radius_1066a( 9) = 307220.000000000
+ M1066a_V%radius_1066a( 10) = 345630.000000000
+ M1066a_V%radius_1066a( 11) = 384030.000000000
+ M1066a_V%radius_1066a( 12) = 422430.000000000
+ M1066a_V%radius_1066a( 13) = 460840.000000000
+ M1066a_V%radius_1066a( 14) = 499240.000000000
+ M1066a_V%radius_1066a( 15) = 537640.000000000
+ M1066a_V%radius_1066a( 16) = 576050.000000000
+ M1066a_V%radius_1066a( 17) = 614450.000000000
+ M1066a_V%radius_1066a( 18) = 652850.000000000
+ M1066a_V%radius_1066a( 19) = 691260.000000000
+ M1066a_V%radius_1066a( 20) = 729660.000000000
+ M1066a_V%radius_1066a( 21) = 768060.000000000
+ M1066a_V%radius_1066a( 22) = 806460.000000000
+ M1066a_V%radius_1066a( 23) = 844870.000000000
+ M1066a_V%radius_1066a( 24) = 883270.000000000
+ M1066a_V%radius_1066a( 25) = 921670.000000000
+ M1066a_V%radius_1066a( 26) = 960080.000000000
+ M1066a_V%radius_1066a( 27) = 998480.000000000
+ M1066a_V%radius_1066a( 28) = 1036880.00000000
+ M1066a_V%radius_1066a( 29) = 1075290.00000000
+ M1066a_V%radius_1066a( 30) = 1113690.00000000
+ M1066a_V%radius_1066a( 31) = 1152090.00000000
+ M1066a_V%radius_1066a( 32) = 1190500.00000000
+ M1066a_V%radius_1066a( 33) = 1229480.00000000
+ M1066a_V%radius_1066a( 34) = 1229480.00000000
+ M1066a_V%radius_1066a( 35) = 1299360.00000000
+ M1066a_V%radius_1066a( 36) = 1369820.00000000
+ M1066a_V%radius_1066a( 37) = 1440280.00000000
+ M1066a_V%radius_1066a( 38) = 1510740.00000000
+ M1066a_V%radius_1066a( 39) = 1581190.00000000
+ M1066a_V%radius_1066a( 40) = 1651650.00000000
+ M1066a_V%radius_1066a( 41) = 1722110.00000000
+ M1066a_V%radius_1066a( 42) = 1792570.00000000
+ M1066a_V%radius_1066a( 43) = 1863030.00000000
+ M1066a_V%radius_1066a( 44) = 1933490.00000000
+ M1066a_V%radius_1066a( 45) = 2003950.00000000
+ M1066a_V%radius_1066a( 46) = 2074410.00000000
+ M1066a_V%radius_1066a( 47) = 2144870.00000000
+ M1066a_V%radius_1066a( 48) = 2215330.00000000
+ M1066a_V%radius_1066a( 49) = 2285790.00000000
+ M1066a_V%radius_1066a( 50) = 2356240.00000000
+ M1066a_V%radius_1066a( 51) = 2426700.00000000
+ M1066a_V%radius_1066a( 52) = 2497160.00000000
+ M1066a_V%radius_1066a( 53) = 2567620.00000000
+ M1066a_V%radius_1066a( 54) = 2638080.00000000
+ M1066a_V%radius_1066a( 55) = 2708540.00000000
+ M1066a_V%radius_1066a( 56) = 2779000.00000000
+ M1066a_V%radius_1066a( 57) = 2849460.00000000
+ M1066a_V%radius_1066a( 58) = 2919920.00000000
+ M1066a_V%radius_1066a( 59) = 2990380.00000000
+ M1066a_V%radius_1066a( 60) = 3060840.00000000
+ M1066a_V%radius_1066a( 61) = 3131300.00000000
+ M1066a_V%radius_1066a( 62) = 3201750.00000000
+ M1066a_V%radius_1066a( 63) = 3272210.00000000
+ M1066a_V%radius_1066a( 64) = 3342670.00000000
+ M1066a_V%radius_1066a( 65) = 3413130.00000000
+ M1066a_V%radius_1066a( 66) = 3484300.00000000
+ M1066a_V%radius_1066a( 67) = 3484300.00000000
+ M1066a_V%radius_1066a( 68) = 3518220.00000000
+ M1066a_V%radius_1066a( 69) = 3552850.00000000
+ M1066a_V%radius_1066a( 70) = 3587490.00000000
+ M1066a_V%radius_1066a( 71) = 3622120.00000000
+ M1066a_V%radius_1066a( 72) = 3656750.00000000
+ M1066a_V%radius_1066a( 73) = 3691380.00000000
+ M1066a_V%radius_1066a( 74) = 3726010.00000000
+ M1066a_V%radius_1066a( 75) = 3760640.00000000
+ M1066a_V%radius_1066a( 76) = 3795270.00000000
+ M1066a_V%radius_1066a( 77) = 3829910.00000000
+ M1066a_V%radius_1066a( 78) = 3864540.00000000
+ M1066a_V%radius_1066a( 79) = 3899170.00000000
+ M1066a_V%radius_1066a( 80) = 3933800.00000000
+ M1066a_V%radius_1066a( 81) = 3968430.00000000
+ M1066a_V%radius_1066a( 82) = 4003060.00000000
+ M1066a_V%radius_1066a( 83) = 4037690.00000000
+ M1066a_V%radius_1066a( 84) = 4072330.00000000
+ M1066a_V%radius_1066a( 85) = 4106960.00000000
+ M1066a_V%radius_1066a( 86) = 4141590.00000000
+ M1066a_V%radius_1066a( 87) = 4176220.00000000
+ M1066a_V%radius_1066a( 88) = 4210850.00000000
+ M1066a_V%radius_1066a( 89) = 4245480.00000000
+ M1066a_V%radius_1066a( 90) = 4280110.00000000
+ M1066a_V%radius_1066a( 91) = 4314740.00000000
+ M1066a_V%radius_1066a( 92) = 4349380.00000000
+ M1066a_V%radius_1066a( 93) = 4384010.00000000
+ M1066a_V%radius_1066a( 94) = 4418640.00000000
+ M1066a_V%radius_1066a( 95) = 4453270.00000000
+ M1066a_V%radius_1066a( 96) = 4487900.00000000
+ M1066a_V%radius_1066a( 97) = 4522530.00000000
+ M1066a_V%radius_1066a( 98) = 4557160.00000000
+ M1066a_V%radius_1066a( 99) = 4591800.00000000
+ M1066a_V%radius_1066a(100) = 4626430.00000000
+ M1066a_V%radius_1066a(101) = 4661060.00000000
+ M1066a_V%radius_1066a(102) = 4695690.00000000
+ M1066a_V%radius_1066a(103) = 4730320.00000000
+ M1066a_V%radius_1066a(104) = 4764950.00000000
+ M1066a_V%radius_1066a(105) = 4799580.00000000
+ M1066a_V%radius_1066a(106) = 4834220.00000000
+ M1066a_V%radius_1066a(107) = 4868850.00000000
+ M1066a_V%radius_1066a(108) = 4903480.00000000
+ M1066a_V%radius_1066a(109) = 4938110.00000000
+ M1066a_V%radius_1066a(110) = 4972740.00000000
+ M1066a_V%radius_1066a(111) = 5007370.00000000
+ M1066a_V%radius_1066a(112) = 5042000.00000000
+ M1066a_V%radius_1066a(113) = 5076640.00000000
+ M1066a_V%radius_1066a(114) = 5111270.00000000
+ M1066a_V%radius_1066a(115) = 5145900.00000000
+ M1066a_V%radius_1066a(116) = 5180530.00000000
+ M1066a_V%radius_1066a(117) = 5215160.00000000
+ M1066a_V%radius_1066a(118) = 5249790.00000000
+ M1066a_V%radius_1066a(119) = 5284420.00000000
+ M1066a_V%radius_1066a(120) = 5319060.00000000
+ M1066a_V%radius_1066a(121) = 5353690.00000000
+ M1066a_V%radius_1066a(122) = 5388320.00000000
+ M1066a_V%radius_1066a(123) = 5422950.00000000
+ M1066a_V%radius_1066a(124) = 5457580.00000000
+ M1066a_V%radius_1066a(125) = 5492210.00000000
+ M1066a_V%radius_1066a(126) = 5526840.00000000
+ M1066a_V%radius_1066a(127) = 5561470.00000000
+ M1066a_V%radius_1066a(128) = 5596110.00000000
+ M1066a_V%radius_1066a(129) = 5630740.00000000
+ M1066a_V%radius_1066a(130) = 5665370.00000000
+ M1066a_V%radius_1066a(131) = 5700000.00000000
+ M1066a_V%radius_1066a(132) = 5700000.00000000
+ M1066a_V%radius_1066a(133) = 5731250.00000000
+ M1066a_V%radius_1066a(134) = 5762500.00000000
+ M1066a_V%radius_1066a(135) = 5793750.00000000
+ M1066a_V%radius_1066a(136) = 5825000.00000000
+ M1066a_V%radius_1066a(137) = 5856250.00000000
+ M1066a_V%radius_1066a(138) = 5887500.00000000
+ M1066a_V%radius_1066a(139) = 5918750.00000000
+ M1066a_V%radius_1066a(140) = 5950000.00000000
+ M1066a_V%radius_1066a(141) = 5950000.00000000
+ M1066a_V%radius_1066a(142) = 5975630.00000000
+ M1066a_V%radius_1066a(143) = 6001250.00000000
+ M1066a_V%radius_1066a(144) = 6026880.00000000
+ M1066a_V%radius_1066a(145) = 6052500.00000000
+ M1066a_V%radius_1066a(146) = 6078130.00000000
+ M1066a_V%radius_1066a(147) = 6103750.00000000
+ M1066a_V%radius_1066a(148) = 6129380.00000000
+ M1066a_V%radius_1066a(149) = 6155000.00000000
+ M1066a_V%radius_1066a(150) = 6180630.00000000
+ M1066a_V%radius_1066a(151) = 6206250.00000000
+ M1066a_V%radius_1066a(152) = 6231880.00000000
+ M1066a_V%radius_1066a(153) = 6257500.00000000
+ M1066a_V%radius_1066a(154) = 6283130.00000000
+ M1066a_V%radius_1066a(155) = 6308750.00000000
+ M1066a_V%radius_1066a(156) = 6334380.00000000
+ M1066a_V%radius_1066a(157) = 6360000.00000000
+ M1066a_V%radius_1066a(158) = 6360000.00000000
+ M1066a_V%radius_1066a(159) = 6365500.00000000
+ M1066a_V%radius_1066a(160) = 6371000.00000000
+
+ M1066a_V%density_1066a( 1) = 13.4290300000000
+ M1066a_V%density_1066a( 2) = 13.4256300000000
+ M1066a_V%density_1066a( 3) = 13.4191300000000
+ M1066a_V%density_1066a( 4) = 13.4135300000000
+ M1066a_V%density_1066a( 5) = 13.4072300000000
+ M1066a_V%density_1066a( 6) = 13.4003200000000
+ M1066a_V%density_1066a( 7) = 13.3929200000000
+ M1066a_V%density_1066a( 8) = 13.3847100000000
+ M1066a_V%density_1066a( 9) = 13.3754000000000
+ M1066a_V%density_1066a( 10) = 13.3649000000000
+ M1066a_V%density_1066a( 11) = 13.3527900000000
+ M1066a_V%density_1066a( 12) = 13.3389800000000
+ M1066a_V%density_1066a( 13) = 13.3238700000000
+ M1066a_V%density_1066a( 14) = 13.3078500000000
+ M1066a_V%density_1066a( 15) = 13.2914400000000
+ M1066a_V%density_1066a( 16) = 13.2750300000000
+ M1066a_V%density_1066a( 17) = 13.2589100000000
+ M1066a_V%density_1066a( 18) = 13.2431000000000
+ M1066a_V%density_1066a( 19) = 13.2275800000000
+ M1066a_V%density_1066a( 20) = 13.2123600000000
+ M1066a_V%density_1066a( 21) = 13.1972500000000
+ M1066a_V%density_1066a( 22) = 13.1823300000000
+ M1066a_V%density_1066a( 23) = 13.1675100000000
+ M1066a_V%density_1066a( 24) = 13.1527800000000
+ M1066a_V%density_1066a( 25) = 13.1382600000000
+ M1066a_V%density_1066a( 26) = 13.1239400000000
+ M1066a_V%density_1066a( 27) = 13.1095200000000
+ M1066a_V%density_1066a( 28) = 13.0953900000000
+ M1066a_V%density_1066a( 29) = 13.0811600000000
+ M1066a_V%density_1066a( 30) = 13.0670400000000
+ M1066a_V%density_1066a( 31) = 13.0525100000000
+ M1066a_V%density_1066a( 32) = 13.0385800000000
+ M1066a_V%density_1066a( 33) = 13.0287500000000
+ M1066a_V%density_1066a( 34) = 12.1606500000000
+ M1066a_V%density_1066a( 35) = 12.1169900000000
+ M1066a_V%density_1066a( 36) = 12.0748300000000
+ M1066a_V%density_1066a( 37) = 12.0330700000000
+ M1066a_V%density_1066a( 38) = 11.9916000000000
+ M1066a_V%density_1066a( 39) = 11.9507300000000
+ M1066a_V%density_1066a( 40) = 11.9104600000000
+ M1066a_V%density_1066a( 41) = 11.8693800000000
+ M1066a_V%density_1066a( 42) = 11.8248100000000
+ M1066a_V%density_1066a( 43) = 11.7753200000000
+ M1066a_V%density_1066a( 44) = 11.7220400000000
+ M1066a_V%density_1066a( 45) = 11.6665500000000
+ M1066a_V%density_1066a( 46) = 11.6085600000000
+ M1066a_V%density_1066a( 47) = 11.5469600000000
+ M1066a_V%density_1066a( 48) = 11.4809600000000
+ M1066a_V%density_1066a( 49) = 11.4116600000000
+ M1066a_V%density_1066a( 50) = 11.3411600000000
+ M1066a_V%density_1066a( 51) = 11.2705500000000
+ M1066a_V%density_1066a( 52) = 11.1982400000000
+ M1066a_V%density_1066a( 53) = 11.1214200000000
+ M1066a_V%density_1066a( 54) = 11.0384100000000
+ M1066a_V%density_1066a( 55) = 10.9511900000000
+ M1066a_V%density_1066a( 56) = 10.8631600000000
+ M1066a_V%density_1066a( 57) = 10.7770300000000
+ M1066a_V%density_1066a( 58) = 10.6925000000000
+ M1066a_V%density_1066a( 59) = 10.6076700000000
+ M1066a_V%density_1066a( 60) = 10.5207300000000
+ M1066a_V%density_1066a( 61) = 10.4312000000000
+ M1066a_V%density_1066a( 62) = 10.3377500000000
+ M1066a_V%density_1066a( 63) = 10.2396100000000
+ M1066a_V%density_1066a( 64) = 10.1378600000000
+ M1066a_V%density_1066a( 65) = 10.0323000000000
+ M1066a_V%density_1066a( 66) = 9.91745000000000
+ M1066a_V%density_1066a( 67) = 5.53205000000000
+ M1066a_V%density_1066a( 68) = 5.52147000000000
+ M1066a_V%density_1066a( 69) = 5.50959000000000
+ M1066a_V%density_1066a( 70) = 5.49821000000000
+ M1066a_V%density_1066a( 71) = 5.48673000000000
+ M1066a_V%density_1066a( 72) = 5.47495000000000
+ M1066a_V%density_1066a( 73) = 5.46297000000000
+ M1066a_V%density_1066a( 74) = 5.45049000000000
+ M1066a_V%density_1066a( 75) = 5.43741000000000
+ M1066a_V%density_1066a( 76) = 5.42382000000000
+ M1066a_V%density_1066a( 77) = 5.40934000000000
+ M1066a_V%density_1066a( 78) = 5.39375000000000
+ M1066a_V%density_1066a( 79) = 5.37717000000000
+ M1066a_V%density_1066a( 80) = 5.35958000000000
+ M1066a_V%density_1066a( 81) = 5.34079000000000
+ M1066a_V%density_1066a( 82) = 5.32100000000000
+ M1066a_V%density_1066a( 83) = 5.30031000000000
+ M1066a_V%density_1066a( 84) = 5.27902000000000
+ M1066a_V%density_1066a( 85) = 5.25733000000000
+ M1066a_V%density_1066a( 86) = 5.23554000000000
+ M1066a_V%density_1066a( 87) = 5.21375000000000
+ M1066a_V%density_1066a( 88) = 5.19196000000000
+ M1066a_V%density_1066a( 89) = 5.17056000000000
+ M1066a_V%density_1066a( 90) = 5.14937000000000
+ M1066a_V%density_1066a( 91) = 5.12827000000000
+ M1066a_V%density_1066a( 92) = 5.10758000000000
+ M1066a_V%density_1066a( 93) = 5.08728000000000
+ M1066a_V%density_1066a( 94) = 5.06738000000000
+ M1066a_V%density_1066a( 95) = 5.04769000000000
+ M1066a_V%density_1066a( 96) = 5.02809000000000
+ M1066a_V%density_1066a( 97) = 5.00869000000000
+ M1066a_V%density_1066a( 98) = 4.98929000000000
+ M1066a_V%density_1066a( 99) = 4.96968000000000
+ M1066a_V%density_1066a(100) = 4.95008000000000
+ M1066a_V%density_1066a(101) = 4.93048000000000
+ M1066a_V%density_1066a(102) = 4.91128000000000
+ M1066a_V%density_1066a(103) = 4.89257000000000
+ M1066a_V%density_1066a(104) = 4.87447000000000
+ M1066a_V%density_1066a(105) = 4.85716000000000
+ M1066a_V%density_1066a(106) = 4.84095000000000
+ M1066a_V%density_1066a(107) = 4.82554000000000
+ M1066a_V%density_1066a(108) = 4.81084000000000
+ M1066a_V%density_1066a(109) = 4.79683000000000
+ M1066a_V%density_1066a(110) = 4.78312000000000
+ M1066a_V%density_1066a(111) = 4.76951000000000
+ M1066a_V%density_1066a(112) = 4.75530000000000
+ M1066a_V%density_1066a(113) = 4.74008000000000
+ M1066a_V%density_1066a(114) = 4.72317000000000
+ M1066a_V%density_1066a(115) = 4.70426000000000
+ M1066a_V%density_1066a(116) = 4.68264000000000
+ M1066a_V%density_1066a(117) = 4.65863000000000
+ M1066a_V%density_1066a(118) = 4.63351000000000
+ M1066a_V%density_1066a(119) = 4.60859000000000
+ M1066a_V%density_1066a(120) = 4.58538000000000
+ M1066a_V%density_1066a(121) = 4.56536000000000
+ M1066a_V%density_1066a(122) = 4.55044000000000
+ M1066a_V%density_1066a(123) = 4.54072000000000
+ M1066a_V%density_1066a(124) = 4.53480000000000
+ M1066a_V%density_1066a(125) = 4.53478000000000
+ M1066a_V%density_1066a(126) = 4.53275000000000
+ M1066a_V%density_1066a(127) = 4.50893000000000
+ M1066a_V%density_1066a(128) = 4.46541000000000
+ M1066a_V%density_1066a(129) = 4.40098000000000
+ M1066a_V%density_1066a(130) = 4.31686000000000
+ M1066a_V%density_1066a(131) = 4.20553000000000
+ M1066a_V%density_1066a(132) = 4.20553000000000
+ M1066a_V%density_1066a(133) = 4.10272000000000
+ M1066a_V%density_1066a(134) = 4.02250000000000
+ M1066a_V%density_1066a(135) = 3.95789000000000
+ M1066a_V%density_1066a(136) = 3.89997000000000
+ M1066a_V%density_1066a(137) = 3.84675000000000
+ M1066a_V%density_1066a(138) = 3.80144000000000
+ M1066a_V%density_1066a(139) = 3.76072000000000
+ M1066a_V%density_1066a(140) = 3.70840000000000
+ M1066a_V%density_1066a(141) = 3.70840000000000
+ M1066a_V%density_1066a(142) = 3.65370000000000
+ M1066a_V%density_1066a(143) = 3.59640000000000
+ M1066a_V%density_1066a(144) = 3.54731000000000
+ M1066a_V%density_1066a(145) = 3.50511000000000
+ M1066a_V%density_1066a(146) = 3.46861000000000
+ M1066a_V%density_1066a(147) = 3.43851000000000
+ M1066a_V%density_1066a(148) = 3.41471000000000
+ M1066a_V%density_1066a(149) = 3.39751000000000
+ M1066a_V%density_1066a(150) = 3.38820000000000
+ M1066a_V%density_1066a(151) = 3.38200000000000
+ M1066a_V%density_1066a(152) = 3.37450000000000
+ M1066a_V%density_1066a(153) = 3.36710000000000
+ M1066a_V%density_1066a(154) = 3.35980000000000
+ M1066a_V%density_1066a(155) = 3.35259000000000
+ M1066a_V%density_1066a(156) = 3.34549000000000
+ M1066a_V%density_1066a(157) = 3.33828000000000
+ M1066a_V%density_1066a(158) = 2.17798000000000
+ M1066a_V%density_1066a(159) = 2.17766000000000
+ M1066a_V%density_1066a(160) = 2.17734000000000
+
+ M1066a_V%vp_1066a( 1) = 11.3383000000000
+ M1066a_V%vp_1066a( 2) = 11.3374000000000
+ M1066a_V%vp_1066a( 3) = 11.3347000000000
+ M1066a_V%vp_1066a( 4) = 11.3301000000000
+ M1066a_V%vp_1066a( 5) = 11.3237000000000
+ M1066a_V%vp_1066a( 6) = 11.3155000000000
+ M1066a_V%vp_1066a( 7) = 11.3056000000000
+ M1066a_V%vp_1066a( 8) = 11.2940000000000
+ M1066a_V%vp_1066a( 9) = 11.2810000000000
+ M1066a_V%vp_1066a( 10) = 11.2666000000000
+ M1066a_V%vp_1066a( 11) = 11.2512000000000
+ M1066a_V%vp_1066a( 12) = 11.2349000000000
+ M1066a_V%vp_1066a( 13) = 11.2181000000000
+ M1066a_V%vp_1066a( 14) = 11.2010000000000
+ M1066a_V%vp_1066a( 15) = 11.1840000000000
+ M1066a_V%vp_1066a( 16) = 11.1672000000000
+ M1066a_V%vp_1066a( 17) = 11.1508000000000
+ M1066a_V%vp_1066a( 18) = 11.1351000000000
+ M1066a_V%vp_1066a( 19) = 11.1201000000000
+ M1066a_V%vp_1066a( 20) = 11.1059000000000
+ M1066a_V%vp_1066a( 21) = 11.0924000000000
+ M1066a_V%vp_1066a( 22) = 11.0798000000000
+ M1066a_V%vp_1066a( 23) = 11.0678000000000
+ M1066a_V%vp_1066a( 24) = 11.0564000000000
+ M1066a_V%vp_1066a( 25) = 11.0455000000000
+ M1066a_V%vp_1066a( 26) = 11.0350000000000
+ M1066a_V%vp_1066a( 27) = 11.0248000000000
+ M1066a_V%vp_1066a( 28) = 11.0149000000000
+ M1066a_V%vp_1066a( 29) = 11.0051000000000
+ M1066a_V%vp_1066a( 30) = 10.9953000000000
+ M1066a_V%vp_1066a( 31) = 10.9857000000000
+ M1066a_V%vp_1066a( 32) = 10.9756000000000
+ M1066a_V%vp_1066a( 33) = 10.9687000000000
+ M1066a_V%vp_1066a( 34) = 10.4140000000000
+ M1066a_V%vp_1066a( 35) = 10.3518000000000
+ M1066a_V%vp_1066a( 36) = 10.2922000000000
+ M1066a_V%vp_1066a( 37) = 10.2351000000000
+ M1066a_V%vp_1066a( 38) = 10.1808000000000
+ M1066a_V%vp_1066a( 39) = 10.1297000000000
+ M1066a_V%vp_1066a( 40) = 10.0788000000000
+ M1066a_V%vp_1066a( 41) = 10.0284000000000
+ M1066a_V%vp_1066a( 42) = 9.97880000000000
+ M1066a_V%vp_1066a( 43) = 9.93070000000000
+ M1066a_V%vp_1066a( 44) = 9.88360000000000
+ M1066a_V%vp_1066a( 45) = 9.83530000000000
+ M1066a_V%vp_1066a( 46) = 9.78250000000000
+ M1066a_V%vp_1066a( 47) = 9.72110000000000
+ M1066a_V%vp_1066a( 48) = 9.65210000000000
+ M1066a_V%vp_1066a( 49) = 9.58060000000000
+ M1066a_V%vp_1066a( 50) = 9.51150000000000
+ M1066a_V%vp_1066a( 51) = 9.44650000000000
+ M1066a_V%vp_1066a( 52) = 9.38280000000000
+ M1066a_V%vp_1066a( 53) = 9.31660000000000
+ M1066a_V%vp_1066a( 54) = 9.24420000000000
+ M1066a_V%vp_1066a( 55) = 9.16580000000000
+ M1066a_V%vp_1066a( 56) = 9.08330000000000
+ M1066a_V%vp_1066a( 57) = 8.99870000000000
+ M1066a_V%vp_1066a( 58) = 8.91160000000000
+ M1066a_V%vp_1066a( 59) = 8.82010000000000
+ M1066a_V%vp_1066a( 60) = 8.72230000000000
+ M1066a_V%vp_1066a( 61) = 8.61710000000000
+ M1066a_V%vp_1066a( 62) = 8.50300000000000
+ M1066a_V%vp_1066a( 63) = 8.38070000000000
+ M1066a_V%vp_1066a( 64) = 8.25560000000000
+ M1066a_V%vp_1066a( 65) = 8.13180000000000
+ M1066a_V%vp_1066a( 66) = 8.01120000000000
+ M1066a_V%vp_1066a( 67) = 13.7172000000000
+ M1066a_V%vp_1066a( 68) = 13.7134000000000
+ M1066a_V%vp_1066a( 69) = 13.7089000000000
+ M1066a_V%vp_1066a( 70) = 13.6806000000000
+ M1066a_V%vp_1066a( 71) = 13.6517000000000
+ M1066a_V%vp_1066a( 72) = 13.6251000000000
+ M1066a_V%vp_1066a( 73) = 13.5916000000000
+ M1066a_V%vp_1066a( 74) = 13.5564000000000
+ M1066a_V%vp_1066a( 75) = 13.5165000000000
+ M1066a_V%vp_1066a( 76) = 13.4725000000000
+ M1066a_V%vp_1066a( 77) = 13.4248000000000
+ M1066a_V%vp_1066a( 78) = 13.3742000000000
+ M1066a_V%vp_1066a( 79) = 13.3216000000000
+ M1066a_V%vp_1066a( 80) = 13.2679000000000
+ M1066a_V%vp_1066a( 81) = 13.2142000000000
+ M1066a_V%vp_1066a( 82) = 13.1619000000000
+ M1066a_V%vp_1066a( 83) = 13.1114000000000
+ M1066a_V%vp_1066a( 84) = 13.0631000000000
+ M1066a_V%vp_1066a( 85) = 13.0174000000000
+ M1066a_V%vp_1066a( 86) = 12.9745000000000
+ M1066a_V%vp_1066a( 87) = 12.9346000000000
+ M1066a_V%vp_1066a( 88) = 12.8977000000000
+ M1066a_V%vp_1066a( 89) = 12.8635000000000
+ M1066a_V%vp_1066a( 90) = 12.8318000000000
+ M1066a_V%vp_1066a( 91) = 12.8022000000000
+ M1066a_V%vp_1066a( 92) = 12.7739000000000
+ M1066a_V%vp_1066a( 93) = 12.7463000000000
+ M1066a_V%vp_1066a( 94) = 12.7186000000000
+ M1066a_V%vp_1066a( 95) = 12.6903000000000
+ M1066a_V%vp_1066a( 96) = 12.6610000000000
+ M1066a_V%vp_1066a( 97) = 12.6302000000000
+ M1066a_V%vp_1066a( 98) = 12.5978000000000
+ M1066a_V%vp_1066a( 99) = 12.5637000000000
+ M1066a_V%vp_1066a(100) = 12.5276000000000
+ M1066a_V%vp_1066a(101) = 12.4893000000000
+ M1066a_V%vp_1066a(102) = 12.4485000000000
+ M1066a_V%vp_1066a(103) = 12.4052000000000
+ M1066a_V%vp_1066a(104) = 12.3592000000000
+ M1066a_V%vp_1066a(105) = 12.3105000000000
+ M1066a_V%vp_1066a(106) = 12.2596000000000
+ M1066a_V%vp_1066a(107) = 12.2072000000000
+ M1066a_V%vp_1066a(108) = 12.1538000000000
+ M1066a_V%vp_1066a(109) = 12.0998000000000
+ M1066a_V%vp_1066a(110) = 12.0458000000000
+ M1066a_V%vp_1066a(111) = 11.9920000000000
+ M1066a_V%vp_1066a(112) = 11.9373000000000
+ M1066a_V%vp_1066a(113) = 11.8804000000000
+ M1066a_V%vp_1066a(114) = 11.8200000000000
+ M1066a_V%vp_1066a(115) = 11.7554000000000
+ M1066a_V%vp_1066a(116) = 11.6844000000000
+ M1066a_V%vp_1066a(117) = 11.6079000000000
+ M1066a_V%vp_1066a(118) = 11.5308000000000
+ M1066a_V%vp_1066a(119) = 11.4579000000000
+ M1066a_V%vp_1066a(120) = 11.3935000000000
+ M1066a_V%vp_1066a(121) = 11.3418000000000
+ M1066a_V%vp_1066a(122) = 11.3085000000000
+ M1066a_V%vp_1066a(123) = 11.2938000000000
+ M1066a_V%vp_1066a(124) = 11.2915000000000
+ M1066a_V%vp_1066a(125) = 11.3049000000000
+ M1066a_V%vp_1066a(126) = 11.3123000000000
+ M1066a_V%vp_1066a(127) = 11.2643000000000
+ M1066a_V%vp_1066a(128) = 11.1635000000000
+ M1066a_V%vp_1066a(129) = 11.0063000000000
+ M1066a_V%vp_1066a(130) = 10.7959000000000
+ M1066a_V%vp_1066a(131) = 10.5143000000000
+ M1066a_V%vp_1066a(132) = 10.5143000000000
+ M1066a_V%vp_1066a(133) = 10.2513000000000
+ M1066a_V%vp_1066a(134) = 10.0402000000000
+ M1066a_V%vp_1066a(135) = 9.86480000000000
+ M1066a_V%vp_1066a(136) = 9.70860000000000
+ M1066a_V%vp_1066a(137) = 9.56810000000000
+ M1066a_V%vp_1066a(138) = 9.45120000000000
+ M1066a_V%vp_1066a(139) = 9.35100000000000
+ M1066a_V%vp_1066a(140) = 9.22830000000000
+ M1066a_V%vp_1066a(141) = 9.22830000000000
+ M1066a_V%vp_1066a(142) = 9.10870000000000
+ M1066a_V%vp_1066a(143) = 8.98230000000000
+ M1066a_V%vp_1066a(144) = 8.85920000000000
+ M1066a_V%vp_1066a(145) = 8.73860000000000
+ M1066a_V%vp_1066a(146) = 8.61930000000000
+ M1066a_V%vp_1066a(147) = 8.50180000000000
+ M1066a_V%vp_1066a(148) = 8.38710000000000
+ M1066a_V%vp_1066a(149) = 8.27360000000000
+ M1066a_V%vp_1066a(150) = 8.15850000000000
+ M1066a_V%vp_1066a(151) = 8.05400000000000
+ M1066a_V%vp_1066a(152) = 7.96520000000000
+ M1066a_V%vp_1066a(153) = 7.87340000000000
+ M1066a_V%vp_1066a(154) = 7.79720000000000
+ M1066a_V%vp_1066a(155) = 7.73910000000000
+ M1066a_V%vp_1066a(156) = 7.71340000000000
+ M1066a_V%vp_1066a(157) = 7.70460000000000
+ M1066a_V%vp_1066a(158) = 4.70220000000000
+ M1066a_V%vp_1066a(159) = 4.70010000000000
+ M1066a_V%vp_1066a(160) = 4.69790000000000
+
+ M1066a_V%vs_1066a( 1) = 3.62980000000000
+ M1066a_V%vs_1066a( 2) = 3.62970000000000
+ M1066a_V%vs_1066a( 3) = 3.62940000000000
+ M1066a_V%vs_1066a( 4) = 3.62880000000000
+ M1066a_V%vs_1066a( 5) = 3.62810000000000
+ M1066a_V%vs_1066a( 6) = 3.62710000000000
+ M1066a_V%vs_1066a( 7) = 3.62590000000000
+ M1066a_V%vs_1066a( 8) = 3.62440000000000
+ M1066a_V%vs_1066a( 9) = 3.62280000000000
+ M1066a_V%vs_1066a( 10) = 3.62090000000000
+ M1066a_V%vs_1066a( 11) = 3.61870000000000
+ M1066a_V%vs_1066a( 12) = 3.61630000000000
+ M1066a_V%vs_1066a( 13) = 3.61370000000000
+ M1066a_V%vs_1066a( 14) = 3.61080000000000
+ M1066a_V%vs_1066a( 15) = 3.60760000000000
+ M1066a_V%vs_1066a( 16) = 3.60420000000000
+ M1066a_V%vs_1066a( 17) = 3.60040000000000
+ M1066a_V%vs_1066a( 18) = 3.59650000000000
+ M1066a_V%vs_1066a( 19) = 3.59220000000000
+ M1066a_V%vs_1066a( 20) = 3.58760000000000
+ M1066a_V%vs_1066a( 21) = 3.58280000000000
+ M1066a_V%vs_1066a( 22) = 3.57770000000000
+ M1066a_V%vs_1066a( 23) = 3.57240000000000
+ M1066a_V%vs_1066a( 24) = 3.56680000000000
+ M1066a_V%vs_1066a( 25) = 3.56100000000000
+ M1066a_V%vs_1066a( 26) = 3.55510000000000
+ M1066a_V%vs_1066a( 27) = 3.54900000000000
+ M1066a_V%vs_1066a( 28) = 3.54280000000000
+ M1066a_V%vs_1066a( 29) = 3.53650000000000
+ M1066a_V%vs_1066a( 30) = 3.53010000000000
+ M1066a_V%vs_1066a( 31) = 3.52380000000000
+ M1066a_V%vs_1066a( 32) = 3.51720000000000
+ M1066a_V%vs_1066a( 33) = 3.51180000000000
+ M1066a_V%vs_1066a( 34) = 0.000000000000000
+ M1066a_V%vs_1066a( 35) = 0.000000000000000
+ M1066a_V%vs_1066a( 36) = 0.000000000000000
+ M1066a_V%vs_1066a( 37) = 0.000000000000000
+ M1066a_V%vs_1066a( 38) = 0.000000000000000
+ M1066a_V%vs_1066a( 39) = 0.000000000000000
+ M1066a_V%vs_1066a( 40) = 0.000000000000000
+ M1066a_V%vs_1066a( 41) = 0.000000000000000
+ M1066a_V%vs_1066a( 42) = 0.000000000000000
+ M1066a_V%vs_1066a( 43) = 0.000000000000000
+ M1066a_V%vs_1066a( 44) = 0.000000000000000
+ M1066a_V%vs_1066a( 45) = 0.000000000000000
+ M1066a_V%vs_1066a( 46) = 0.000000000000000
+ M1066a_V%vs_1066a( 47) = 0.000000000000000
+ M1066a_V%vs_1066a( 48) = 0.000000000000000
+ M1066a_V%vs_1066a( 49) = 0.000000000000000
+ M1066a_V%vs_1066a( 50) = 0.000000000000000
+ M1066a_V%vs_1066a( 51) = 0.000000000000000
+ M1066a_V%vs_1066a( 52) = 0.000000000000000
+ M1066a_V%vs_1066a( 53) = 0.000000000000000
+ M1066a_V%vs_1066a( 54) = 0.000000000000000
+ M1066a_V%vs_1066a( 55) = 0.000000000000000
+ M1066a_V%vs_1066a( 56) = 0.000000000000000
+ M1066a_V%vs_1066a( 57) = 0.000000000000000
+ M1066a_V%vs_1066a( 58) = 0.000000000000000
+ M1066a_V%vs_1066a( 59) = 0.000000000000000
+ M1066a_V%vs_1066a( 60) = 0.000000000000000
+ M1066a_V%vs_1066a( 61) = 0.000000000000000
+ M1066a_V%vs_1066a( 62) = 0.000000000000000
+ M1066a_V%vs_1066a( 63) = 0.000000000000000
+ M1066a_V%vs_1066a( 64) = 0.000000000000000
+ M1066a_V%vs_1066a( 65) = 0.000000000000000
+ M1066a_V%vs_1066a( 66) = 0.000000000000000
+ M1066a_V%vs_1066a( 67) = 7.24980000000000
+ M1066a_V%vs_1066a( 68) = 7.23760000000000
+ M1066a_V%vs_1066a( 69) = 7.22390000000000
+ M1066a_V%vs_1066a( 70) = 7.21000000000000
+ M1066a_V%vs_1066a( 71) = 7.19640000000000
+ M1066a_V%vs_1066a( 72) = 7.18300000000000
+ M1066a_V%vs_1066a( 73) = 7.16990000000000
+ M1066a_V%vs_1066a( 74) = 7.15710000000000
+ M1066a_V%vs_1066a( 75) = 7.14450000000000
+ M1066a_V%vs_1066a( 76) = 7.13200000000000
+ M1066a_V%vs_1066a( 77) = 7.11960000000000
+ M1066a_V%vs_1066a( 78) = 7.10740000000000
+ M1066a_V%vs_1066a( 79) = 7.09530000000000
+ M1066a_V%vs_1066a( 80) = 7.08320000000000
+ M1066a_V%vs_1066a( 81) = 7.07120000000000
+ M1066a_V%vs_1066a( 82) = 7.05920000000000
+ M1066a_V%vs_1066a( 83) = 7.04710000000000
+ M1066a_V%vs_1066a( 84) = 7.03470000000000
+ M1066a_V%vs_1066a( 85) = 7.02190000000000
+ M1066a_V%vs_1066a( 86) = 7.00860000000000
+ M1066a_V%vs_1066a( 87) = 6.99470000000000
+ M1066a_V%vs_1066a( 88) = 6.98030000000000
+ M1066a_V%vs_1066a( 89) = 6.96510000000000
+ M1066a_V%vs_1066a( 90) = 6.94930000000000
+ M1066a_V%vs_1066a( 91) = 6.93290000000000
+ M1066a_V%vs_1066a( 92) = 6.91620000000000
+ M1066a_V%vs_1066a( 93) = 6.89910000000000
+ M1066a_V%vs_1066a( 94) = 6.88200000000000
+ M1066a_V%vs_1066a( 95) = 6.86520000000000
+ M1066a_V%vs_1066a( 96) = 6.84900000000000
+ M1066a_V%vs_1066a( 97) = 6.83340000000000
+ M1066a_V%vs_1066a( 98) = 6.81820000000000
+ M1066a_V%vs_1066a( 99) = 6.80360000000000
+ M1066a_V%vs_1066a(100) = 6.78910000000000
+ M1066a_V%vs_1066a(101) = 6.77440000000000
+ M1066a_V%vs_1066a(102) = 6.75890000000000
+ M1066a_V%vs_1066a(103) = 6.74270000000000
+ M1066a_V%vs_1066a(104) = 6.72550000000000
+ M1066a_V%vs_1066a(105) = 6.70730000000000
+ M1066a_V%vs_1066a(106) = 6.68810000000000
+ M1066a_V%vs_1066a(107) = 6.66840000000000
+ M1066a_V%vs_1066a(108) = 6.64850000000000
+ M1066a_V%vs_1066a(109) = 6.62880000000000
+ M1066a_V%vs_1066a(110) = 6.60950000000000
+ M1066a_V%vs_1066a(111) = 6.59110000000000
+ M1066a_V%vs_1066a(112) = 6.57310000000000
+ M1066a_V%vs_1066a(113) = 6.55480000000000
+ M1066a_V%vs_1066a(114) = 6.53510000000000
+ M1066a_V%vs_1066a(115) = 6.51330000000000
+ M1066a_V%vs_1066a(116) = 6.48810000000000
+ M1066a_V%vs_1066a(117) = 6.45940000000000
+ M1066a_V%vs_1066a(118) = 6.42860000000000
+ M1066a_V%vs_1066a(119) = 6.39760000000000
+ M1066a_V%vs_1066a(120) = 6.36840000000000
+ M1066a_V%vs_1066a(121) = 6.34280000000000
+ M1066a_V%vs_1066a(122) = 6.32350000000000
+ M1066a_V%vs_1066a(123) = 6.31140000000000
+ M1066a_V%vs_1066a(124) = 6.30410000000000
+ M1066a_V%vs_1066a(125) = 6.30520000000000
+ M1066a_V%vs_1066a(126) = 6.30210000000000
+ M1066a_V%vs_1066a(127) = 6.26430000000000
+ M1066a_V%vs_1066a(128) = 6.19470000000000
+ M1066a_V%vs_1066a(129) = 6.09120000000000
+ M1066a_V%vs_1066a(130) = 5.95550000000000
+ M1066a_V%vs_1066a(131) = 5.77550000000000
+ M1066a_V%vs_1066a(132) = 5.77550000000000
+ M1066a_V%vs_1066a(133) = 5.60830000000000
+ M1066a_V%vs_1066a(134) = 5.47520000000000
+ M1066a_V%vs_1066a(135) = 5.36530000000000
+ M1066a_V%vs_1066a(136) = 5.26650000000000
+ M1066a_V%vs_1066a(137) = 5.17620000000000
+ M1066a_V%vs_1066a(138) = 5.09960000000000
+ M1066a_V%vs_1066a(139) = 5.03220000000000
+ M1066a_V%vs_1066a(140) = 4.94880000000000
+ M1066a_V%vs_1066a(141) = 4.94880000000000
+ M1066a_V%vs_1066a(142) = 4.86670000000000
+ M1066a_V%vs_1066a(143) = 4.78060000000000
+ M1066a_V%vs_1066a(144) = 4.69950000000000
+ M1066a_V%vs_1066a(145) = 4.62110000000000
+ M1066a_V%vs_1066a(146) = 4.54790000000000
+ M1066a_V%vs_1066a(147) = 4.48820000000000
+ M1066a_V%vs_1066a(148) = 4.44210000000000
+ M1066a_V%vs_1066a(149) = 4.40840000000000
+ M1066a_V%vs_1066a(150) = 4.38740000000000
+ M1066a_V%vs_1066a(151) = 4.37950000000000
+ M1066a_V%vs_1066a(152) = 4.39040000000000
+ M1066a_V%vs_1066a(153) = 4.43310000000000
+ M1066a_V%vs_1066a(154) = 4.48300000000000
+ M1066a_V%vs_1066a(155) = 4.53890000000000
+ M1066a_V%vs_1066a(156) = 4.60400000000000
+ M1066a_V%vs_1066a(157) = 4.64870000000000
+ M1066a_V%vs_1066a(158) = 2.58060000000000
+ M1066a_V%vs_1066a(159) = 2.58140000000000
+ M1066a_V%vs_1066a(160) = 2.58220000000000
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+ M1066a_V%vp_1066a(158:160) = M1066a_V%vp_1066a(157)
+ M1066a_V%vs_1066a(158:160) = M1066a_V%vs_1066a(157)
+ M1066a_V%density_1066a(158:160) = M1066a_V%density_1066a(157)
+ endif
+
+ M1066a_V%Qkappa_1066a( 1) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 2) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 3) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 4) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 5) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 6) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 7) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 8) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 9) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 10) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 11) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 12) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 13) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 14) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 15) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 16) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 17) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 18) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 19) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 20) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 21) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 22) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 23) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 24) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 25) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 26) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 27) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 28) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 29) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 30) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 31) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 32) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 33) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 34) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 35) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 36) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 37) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 38) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 39) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 40) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 41) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 42) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 43) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 44) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 45) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 46) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 47) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 48) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 49) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 50) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 51) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 52) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 53) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 54) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 55) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 56) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 57) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 58) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 59) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 60) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 61) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 62) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 63) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 64) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 65) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 66) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 67) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 68) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 69) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 70) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 71) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 72) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 73) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 74) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 75) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 76) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 77) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 78) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 79) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 80) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 81) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 82) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 83) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 84) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 85) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 86) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 87) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 88) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 89) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 90) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 91) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 92) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 93) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 94) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 95) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 96) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 97) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 98) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 99) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(100) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(101) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(102) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(103) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(104) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(105) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(106) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(107) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(108) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(109) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(110) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(111) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(112) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(113) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(114) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(115) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(116) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(117) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(118) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(119) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(120) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(121) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(122) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(123) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(124) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(125) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(126) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(127) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(128) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(129) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(130) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(131) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(132) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(133) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(134) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(135) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(136) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(137) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(138) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(139) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(140) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(141) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(142) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(143) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(144) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(145) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(146) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(147) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(148) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(149) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(150) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(151) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(152) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(153) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(154) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(155) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(156) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(157) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(158) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(159) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(160) = 5893.00000000000
+
+ M1066a_V%Qmu_1066a( 1) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 2) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 3) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 4) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 5) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 6) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 7) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 8) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 9) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 10) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 11) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 12) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 13) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 14) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 15) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 16) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 17) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 18) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 19) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 20) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 21) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 22) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 23) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 24) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 25) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 26) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 27) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 28) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 29) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 30) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 31) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 32) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 33) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 34) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 35) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 36) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 37) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 38) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 39) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 40) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 41) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 42) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 43) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 44) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 45) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 46) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 47) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 48) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 49) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 50) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 51) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 52) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 53) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 54) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 55) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 56) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 57) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 58) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 59) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 60) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 61) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 62) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 63) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 64) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 65) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 66) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 67) = 332.000000000000
+ M1066a_V%Qmu_1066a( 68) = 332.000000000000
+ M1066a_V%Qmu_1066a( 69) = 332.000000000000
+ M1066a_V%Qmu_1066a( 70) = 332.000000000000
+ M1066a_V%Qmu_1066a( 71) = 332.000000000000
+ M1066a_V%Qmu_1066a( 72) = 332.000000000000
+ M1066a_V%Qmu_1066a( 73) = 332.000000000000
+ M1066a_V%Qmu_1066a( 74) = 332.000000000000
+ M1066a_V%Qmu_1066a( 75) = 332.000000000000
+ M1066a_V%Qmu_1066a( 76) = 332.000000000000
+ M1066a_V%Qmu_1066a( 77) = 332.000000000000
+ M1066a_V%Qmu_1066a( 78) = 332.000000000000
+ M1066a_V%Qmu_1066a( 79) = 332.000000000000
+ M1066a_V%Qmu_1066a( 80) = 332.000000000000
+ M1066a_V%Qmu_1066a( 81) = 332.000000000000
+ M1066a_V%Qmu_1066a( 82) = 332.000000000000
+ M1066a_V%Qmu_1066a( 83) = 332.000000000000
+ M1066a_V%Qmu_1066a( 84) = 332.000000000000
+ M1066a_V%Qmu_1066a( 85) = 332.000000000000
+ M1066a_V%Qmu_1066a( 86) = 332.000000000000
+ M1066a_V%Qmu_1066a( 87) = 332.000000000000
+ M1066a_V%Qmu_1066a( 88) = 332.000000000000
+ M1066a_V%Qmu_1066a( 89) = 332.000000000000
+ M1066a_V%Qmu_1066a( 90) = 332.000000000000
+ M1066a_V%Qmu_1066a( 91) = 332.000000000000
+ M1066a_V%Qmu_1066a( 92) = 332.000000000000
+ M1066a_V%Qmu_1066a( 93) = 332.000000000000
+ M1066a_V%Qmu_1066a( 94) = 332.000000000000
+ M1066a_V%Qmu_1066a( 95) = 332.000000000000
+ M1066a_V%Qmu_1066a( 96) = 332.000000000000
+ M1066a_V%Qmu_1066a( 97) = 332.000000000000
+ M1066a_V%Qmu_1066a( 98) = 332.000000000000
+ M1066a_V%Qmu_1066a( 99) = 332.000000000000
+ M1066a_V%Qmu_1066a(100) = 332.000000000000
+ M1066a_V%Qmu_1066a(101) = 332.000000000000
+ M1066a_V%Qmu_1066a(102) = 332.000000000000
+ M1066a_V%Qmu_1066a(103) = 332.000000000000
+ M1066a_V%Qmu_1066a(104) = 332.000000000000
+ M1066a_V%Qmu_1066a(105) = 332.000000000000
+ M1066a_V%Qmu_1066a(106) = 332.000000000000
+ M1066a_V%Qmu_1066a(107) = 332.000000000000
+ M1066a_V%Qmu_1066a(108) = 332.000000000000
+ M1066a_V%Qmu_1066a(109) = 332.000000000000
+ M1066a_V%Qmu_1066a(110) = 332.000000000000
+ M1066a_V%Qmu_1066a(111) = 332.000000000000
+ M1066a_V%Qmu_1066a(112) = 332.000000000000
+ M1066a_V%Qmu_1066a(113) = 332.000000000000
+ M1066a_V%Qmu_1066a(114) = 332.000000000000
+ M1066a_V%Qmu_1066a(115) = 332.000000000000
+ M1066a_V%Qmu_1066a(116) = 332.000000000000
+ M1066a_V%Qmu_1066a(117) = 332.000000000000
+ M1066a_V%Qmu_1066a(118) = 332.000000000000
+ M1066a_V%Qmu_1066a(119) = 332.000000000000
+ M1066a_V%Qmu_1066a(120) = 332.000000000000
+ M1066a_V%Qmu_1066a(121) = 332.000000000000
+ M1066a_V%Qmu_1066a(122) = 332.000000000000
+ M1066a_V%Qmu_1066a(123) = 332.000000000000
+ M1066a_V%Qmu_1066a(124) = 332.000000000000
+ M1066a_V%Qmu_1066a(125) = 332.000000000000
+ M1066a_V%Qmu_1066a(126) = 332.000000000000
+ M1066a_V%Qmu_1066a(127) = 332.000000000000
+ M1066a_V%Qmu_1066a(128) = 332.000000000000
+ M1066a_V%Qmu_1066a(129) = 332.000000000000
+ M1066a_V%Qmu_1066a(130) = 332.000000000000
+ M1066a_V%Qmu_1066a(131) = 332.000000000000
+ M1066a_V%Qmu_1066a(132) = 276.800000000000
+ M1066a_V%Qmu_1066a(133) = 276.800000000000
+ M1066a_V%Qmu_1066a(134) = 276.800000000000
+ M1066a_V%Qmu_1066a(135) = 276.800000000000
+ M1066a_V%Qmu_1066a(136) = 276.800000000000
+ M1066a_V%Qmu_1066a(137) = 276.800000000000
+ M1066a_V%Qmu_1066a(138) = 276.800000000000
+ M1066a_V%Qmu_1066a(139) = 276.800000000000
+ M1066a_V%Qmu_1066a(140) = 276.800000000000
+ M1066a_V%Qmu_1066a(141) = 117.900000000000
+ M1066a_V%Qmu_1066a(142) = 117.900000000000
+ M1066a_V%Qmu_1066a(143) = 117.900000000000
+ M1066a_V%Qmu_1066a(144) = 117.900000000000
+ M1066a_V%Qmu_1066a(145) = 117.900000000000
+ M1066a_V%Qmu_1066a(146) = 117.900000000000
+ M1066a_V%Qmu_1066a(147) = 117.900000000000
+ M1066a_V%Qmu_1066a(148) = 117.900000000000
+ M1066a_V%Qmu_1066a(149) = 117.900000000000
+ M1066a_V%Qmu_1066a(150) = 117.900000000000
+ M1066a_V%Qmu_1066a(151) = 117.900000000000
+ M1066a_V%Qmu_1066a(152) = 117.900000000000
+ M1066a_V%Qmu_1066a(153) = 117.900000000000
+ M1066a_V%Qmu_1066a(154) = 117.900000000000
+ M1066a_V%Qmu_1066a(155) = 117.900000000000
+ M1066a_V%Qmu_1066a(156) = 117.900000000000
+ M1066a_V%Qmu_1066a(157) = 117.900000000000
+ M1066a_V%Qmu_1066a(158) = 117.900000000000
+ M1066a_V%Qmu_1066a(159) = 117.900000000000
+ M1066a_V%Qmu_1066a(160) = 117.900000000000
+
+! strip the crust and replace it by mantle if we use an external crustal model
+ if(USE_EXTERNAL_CRUSTAL_MODEL) then
+ do i=NR_1066A-3,NR_1066A
+ M1066a_V%density_1066a(i) = M1066a_V%density_1066a(NR_1066A-4)
+ M1066a_V%vp_1066a(i) = M1066a_V%vp_1066a(NR_1066A-4)
+ M1066a_V%vs_1066a(i) = M1066a_V%vs_1066a(NR_1066A-4)
+ M1066a_V%Qkappa_1066a(i) = M1066a_V%Qkappa_1066a(NR_1066A-4)
+ M1066a_V%Qmu_1066a(i) = M1066a_V%Qmu_1066a(NR_1066A-4)
+ enddo
+ endif
+
+ end subroutine define_model_1066a
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_ak135.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ak135.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_ak135.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_ak135.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,1038 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 model_ak135(x,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V)
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+! input:
+! radius r: meters
+
+! output:
+! density rho: kg/m^3
+! compressional wave speed vp: km/s
+! shear wave speed vs: km/s
+
+ integer iregion_code
+
+ double precision x,rho,vp,vs,Qmu,Qkappa
+
+ integer i
+
+ double precision r,frac,scaleval
+
+!! DK DK UGLY implementation of model ak135 below and its radii in
+!! DK DK UGLY subroutine read_parameter_file.f90 has not been thoroughly
+!! DK DK UGLY checked yet
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+ i = 1
+ do while(r >= Mak135_V%radius_ak135(i) .and. i /= NR_AK135)
+ i = i + 1
+ enddo
+
+! make sure we stay in the right region and never take a point above
+! and a point below the ICB or the CMB and interpolate between them,
+! which would lead to a wrong value (keeping in mind that we interpolate
+! between points i-1 and i below)
+ if(iregion_code == IREGION_INNER_CORE .and. i > 25) i = 25
+
+ if(iregion_code == IREGION_OUTER_CORE .and. i < 27) i = 27
+ if(iregion_code == IREGION_OUTER_CORE .and. i > 71) i = 71
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. i < 73) i = 73
+
+ if(i == 1) then
+ rho = Mak135_V%density_ak135(i)
+ vp = Mak135_V%vp_ak135(i)
+ vs = Mak135_V%vs_ak135(i)
+ Qmu = Mak135_V%Qmu_ak135(i)
+ Qkappa = Mak135_V%Qkappa_ak135(i)
+ else
+
+! interpolate from radius_ak135(i-1) to r using the values at i-1 and i
+ frac = (r-Mak135_V%radius_ak135(i-1))/(Mak135_V%radius_ak135(i)-Mak135_V%radius_ak135(i-1))
+
+ rho = Mak135_V%density_ak135(i-1) + frac * (Mak135_V%density_ak135(i)-Mak135_V%density_ak135(i-1))
+ vp = Mak135_V%vp_ak135(i-1) + frac * (Mak135_V%vp_ak135(i)-Mak135_V%vp_ak135(i-1))
+ vs = Mak135_V%vs_ak135(i-1) + frac * (Mak135_V%vs_ak135(i)-Mak135_V%vs_ak135(i-1))
+ Qmu = Mak135_V%Qmu_ak135(i-1) + frac * (Mak135_V%Qmu_ak135(i)-Mak135_V%Qmu_ak135(i-1))
+ Qkappa = Mak135_V%Qkappa_ak135(i-1) + frac * (Mak135_V%Qkappa_ak135(i)-Mak135_V%Qkappa_ak135(i-1))
+
+ endif
+
+! make sure Vs is zero in the outer core even if roundoff errors on depth
+! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
+ if(iregion_code == IREGION_OUTER_CORE) then
+ vs = 0.d0
+ Qkappa = 3000.d0
+ Qmu = 3000.d0
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine model_ak135
+
+!-------------------
+
+ subroutine define_model_ak135(USE_EXTERNAL_CRUSTAL_MODEL,Mak135_V)
+
+ implicit none
+ include "constants.h"
+
+! 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
+
+ logical USE_EXTERNAL_CRUSTAL_MODEL
+
+ integer i
+
+! define all the values in the model
+
+ Mak135_V%radius_ak135( 1) = 0.000000000000000
+ Mak135_V%radius_ak135( 2) = 50710.0000000000
+ Mak135_V%radius_ak135( 3) = 101430.000000000
+ Mak135_V%radius_ak135( 4) = 152140.000000000
+ Mak135_V%radius_ak135( 5) = 202850.000000000
+ Mak135_V%radius_ak135( 6) = 253560.000000000
+ Mak135_V%radius_ak135( 7) = 304280.000000000
+ Mak135_V%radius_ak135( 8) = 354990.000000000
+ Mak135_V%radius_ak135( 9) = 405700.000000000
+ Mak135_V%radius_ak135( 10) = 456410.000000000
+ Mak135_V%radius_ak135( 11) = 507130.000000000
+ Mak135_V%radius_ak135( 12) = 557840.000000000
+ Mak135_V%radius_ak135( 13) = 608550.000000000
+ Mak135_V%radius_ak135( 14) = 659260.000000000
+ Mak135_V%radius_ak135( 15) = 709980.000000000
+ Mak135_V%radius_ak135( 16) = 760690.000000000
+ Mak135_V%radius_ak135( 17) = 811400.000000000
+ Mak135_V%radius_ak135( 18) = 862110.000000000
+ Mak135_V%radius_ak135( 19) = 912830.000000000
+ Mak135_V%radius_ak135( 20) = 963540.000000000
+ Mak135_V%radius_ak135( 21) = 1014250.00000000
+ Mak135_V%radius_ak135( 22) = 1064960.00000000
+ Mak135_V%radius_ak135( 23) = 1115680.00000000
+ Mak135_V%radius_ak135( 24) = 1166390.00000000
+ Mak135_V%radius_ak135( 25) = 1217500.00000000
+ Mak135_V%radius_ak135( 26) = 1217500.00000000
+ Mak135_V%radius_ak135( 27) = 1267430.00000000
+ Mak135_V%radius_ak135( 28) = 1317760.00000000
+ Mak135_V%radius_ak135( 29) = 1368090.00000000
+ Mak135_V%radius_ak135( 30) = 1418420.00000000
+ Mak135_V%radius_ak135( 31) = 1468760.00000000
+ Mak135_V%radius_ak135( 32) = 1519090.00000000
+ Mak135_V%radius_ak135( 33) = 1569420.00000000
+ Mak135_V%radius_ak135( 34) = 1619750.00000000
+ Mak135_V%radius_ak135( 35) = 1670080.00000000
+ Mak135_V%radius_ak135( 36) = 1720410.00000000
+ Mak135_V%radius_ak135( 37) = 1770740.00000000
+ Mak135_V%radius_ak135( 38) = 1821070.00000000
+ Mak135_V%radius_ak135( 39) = 1871400.00000000
+ Mak135_V%radius_ak135( 40) = 1921740.00000000
+ Mak135_V%radius_ak135( 41) = 1972070.00000000
+ Mak135_V%radius_ak135( 42) = 2022400.00000000
+ Mak135_V%radius_ak135( 43) = 2072730.00000000
+ Mak135_V%radius_ak135( 44) = 2123060.00000000
+ Mak135_V%radius_ak135( 45) = 2173390.00000000
+ Mak135_V%radius_ak135( 46) = 2223720.00000000
+ Mak135_V%radius_ak135( 47) = 2274050.00000000
+ Mak135_V%radius_ak135( 48) = 2324380.00000000
+ Mak135_V%radius_ak135( 49) = 2374720.00000000
+ Mak135_V%radius_ak135( 50) = 2425050.00000000
+ Mak135_V%radius_ak135( 51) = 2475380.00000000
+ Mak135_V%radius_ak135( 52) = 2525710.00000000
+ Mak135_V%radius_ak135( 53) = 2576040.00000000
+ Mak135_V%radius_ak135( 54) = 2626370.00000000
+ Mak135_V%radius_ak135( 55) = 2676700.00000000
+ Mak135_V%radius_ak135( 56) = 2727030.00000000
+ Mak135_V%radius_ak135( 57) = 2777360.00000000
+ Mak135_V%radius_ak135( 58) = 2827700.00000000
+ Mak135_V%radius_ak135( 59) = 2878030.00000000
+ Mak135_V%radius_ak135( 60) = 2928360.00000000
+ Mak135_V%radius_ak135( 61) = 2978690.00000000
+ Mak135_V%radius_ak135( 62) = 3029020.00000000
+ Mak135_V%radius_ak135( 63) = 3079350.00000000
+ Mak135_V%radius_ak135( 64) = 3129680.00000000
+ Mak135_V%radius_ak135( 65) = 3180010.00000000
+ Mak135_V%radius_ak135( 66) = 3230340.00000000
+ Mak135_V%radius_ak135( 67) = 3280680.00000000
+ Mak135_V%radius_ak135( 68) = 3331010.00000000
+ Mak135_V%radius_ak135( 69) = 3381340.00000000
+ Mak135_V%radius_ak135( 70) = 3431670.00000000
+ Mak135_V%radius_ak135( 71) = 3479500.00000000
+ Mak135_V%radius_ak135( 72) = 3479500.00000000
+ Mak135_V%radius_ak135( 73) = 3531670.00000000
+ Mak135_V%radius_ak135( 74) = 3581330.00000000
+ Mak135_V%radius_ak135( 75) = 3631000.00000000
+ Mak135_V%radius_ak135( 76) = 3631000.00000000
+ Mak135_V%radius_ak135( 77) = 3681000.00000000
+ Mak135_V%radius_ak135( 78) = 3731000.00000000
+ Mak135_V%radius_ak135( 79) = 3779500.00000000
+ Mak135_V%radius_ak135( 80) = 3829000.00000000
+ Mak135_V%radius_ak135( 81) = 3878500.00000000
+ Mak135_V%radius_ak135( 82) = 3928000.00000000
+ Mak135_V%radius_ak135( 83) = 3977500.00000000
+ Mak135_V%radius_ak135( 84) = 4027000.00000000
+ Mak135_V%radius_ak135( 85) = 4076500.00000000
+ Mak135_V%radius_ak135( 86) = 4126000.00000000
+ Mak135_V%radius_ak135( 87) = 4175500.00000000
+ Mak135_V%radius_ak135( 88) = 4225000.00000000
+ Mak135_V%radius_ak135( 89) = 4274500.00000000
+ Mak135_V%radius_ak135( 90) = 4324000.00000000
+ Mak135_V%radius_ak135( 91) = 4373500.00000000
+ Mak135_V%radius_ak135( 92) = 4423000.00000000
+ Mak135_V%radius_ak135( 93) = 4472500.00000000
+ Mak135_V%radius_ak135( 94) = 4522000.00000000
+ Mak135_V%radius_ak135( 95) = 4571500.00000000
+ Mak135_V%radius_ak135( 96) = 4621000.00000000
+ Mak135_V%radius_ak135( 97) = 4670500.00000000
+ Mak135_V%radius_ak135( 98) = 4720000.00000000
+ Mak135_V%radius_ak135( 99) = 4769500.00000000
+ Mak135_V%radius_ak135(100) = 4819000.00000000
+ Mak135_V%radius_ak135(101) = 4868500.00000000
+ Mak135_V%radius_ak135(102) = 4918000.00000000
+ Mak135_V%radius_ak135(103) = 4967500.00000000
+ Mak135_V%radius_ak135(104) = 5017000.00000000
+ Mak135_V%radius_ak135(105) = 5066500.00000000
+ Mak135_V%radius_ak135(106) = 5116000.00000000
+ Mak135_V%radius_ak135(107) = 5165500.00000000
+ Mak135_V%radius_ak135(108) = 5215000.00000000
+ Mak135_V%radius_ak135(109) = 5264500.00000000
+ Mak135_V%radius_ak135(110) = 5314000.00000000
+ Mak135_V%radius_ak135(111) = 5363500.00000000
+ Mak135_V%radius_ak135(112) = 5413000.00000000
+ Mak135_V%radius_ak135(113) = 5462500.00000000
+ Mak135_V%radius_ak135(114) = 5512000.00000000
+ Mak135_V%radius_ak135(115) = 5561500.00000000
+ Mak135_V%radius_ak135(116) = 5611000.00000000
+ Mak135_V%radius_ak135(117) = 5661000.00000000
+ Mak135_V%radius_ak135(118) = 5711000.00000000
+ Mak135_V%radius_ak135(119) = 5711000.00000000
+ Mak135_V%radius_ak135(120) = 5761000.00000000
+ Mak135_V%radius_ak135(121) = 5811000.00000000
+ Mak135_V%radius_ak135(122) = 5861000.00000000
+ Mak135_V%radius_ak135(123) = 5911000.00000000
+ Mak135_V%radius_ak135(124) = 5961000.00000000
+ Mak135_V%radius_ak135(125) = 5961000.00000000
+ Mak135_V%radius_ak135(126) = 6011000.00000000
+ Mak135_V%radius_ak135(127) = 6061000.00000000
+ Mak135_V%radius_ak135(128) = 6111000.00000000
+ Mak135_V%radius_ak135(129) = 6161000.00000000
+ Mak135_V%radius_ak135(130) = 6161000.00000000
+ Mak135_V%radius_ak135(131) = 6206000.00000000
+ Mak135_V%radius_ak135(132) = 6251000.00000000
+ Mak135_V%radius_ak135(133) = 6291000.00000000
+ Mak135_V%radius_ak135(134) = 6291000.00000000
+ Mak135_V%radius_ak135(135) = 6328000.00000000
+ Mak135_V%radius_ak135(136) = 6353000.00000000
+ Mak135_V%radius_ak135(137) = 6353000.00000000
+ Mak135_V%radius_ak135(138) = 6361000.00000000
+ Mak135_V%radius_ak135(139) = 6361000.00000000
+ Mak135_V%radius_ak135(140) = 6367700.00000000
+ Mak135_V%radius_ak135(141) = 6367700.00000000
+ Mak135_V%radius_ak135(142) = 6368000.00000000
+ Mak135_V%radius_ak135(143) = 6368000.00000000
+ Mak135_V%radius_ak135(144) = 6371000.00000000
+
+ Mak135_V%density_ak135( 1) = 13.0122000000000
+ Mak135_V%density_ak135( 2) = 13.0117000000000
+ Mak135_V%density_ak135( 3) = 13.0100000000000
+ Mak135_V%density_ak135( 4) = 13.0074000000000
+ Mak135_V%density_ak135( 5) = 13.0036000000000
+ Mak135_V%density_ak135( 6) = 12.9988000000000
+ Mak135_V%density_ak135( 7) = 12.9929000000000
+ Mak135_V%density_ak135( 8) = 12.9859000000000
+ Mak135_V%density_ak135( 9) = 12.9779000000000
+ Mak135_V%density_ak135( 10) = 12.9688000000000
+ Mak135_V%density_ak135( 11) = 12.9586000000000
+ Mak135_V%density_ak135( 12) = 12.9474000000000
+ Mak135_V%density_ak135( 13) = 12.9351000000000
+ Mak135_V%density_ak135( 14) = 12.9217000000000
+ Mak135_V%density_ak135( 15) = 12.9072000000000
+ Mak135_V%density_ak135( 16) = 12.8917000000000
+ Mak135_V%density_ak135( 17) = 12.8751000000000
+ Mak135_V%density_ak135( 18) = 12.8574000000000
+ Mak135_V%density_ak135( 19) = 12.8387000000000
+ Mak135_V%density_ak135( 20) = 12.8188000000000
+ Mak135_V%density_ak135( 21) = 12.7980000000000
+ Mak135_V%density_ak135( 22) = 12.7760000000000
+ Mak135_V%density_ak135( 23) = 12.7530000000000
+ Mak135_V%density_ak135( 24) = 12.7289000000000
+ Mak135_V%density_ak135( 25) = 12.7037000000000
+ Mak135_V%density_ak135( 26) = 12.1391000000000
+ Mak135_V%density_ak135( 27) = 12.1133000000000
+ Mak135_V%density_ak135( 28) = 12.0867000000000
+ Mak135_V%density_ak135( 29) = 12.0593000000000
+ Mak135_V%density_ak135( 30) = 12.0311000000000
+ Mak135_V%density_ak135( 31) = 12.0001000000000
+ Mak135_V%density_ak135( 32) = 11.9722000000000
+ Mak135_V%density_ak135( 33) = 11.9414000000000
+ Mak135_V%density_ak135( 34) = 11.9098000000000
+ Mak135_V%density_ak135( 35) = 11.8772000000000
+ Mak135_V%density_ak135( 36) = 11.8437000000000
+ Mak135_V%density_ak135( 37) = 11.8092000000000
+ Mak135_V%density_ak135( 38) = 11.7737000000000
+ Mak135_V%density_ak135( 39) = 11.7373000000000
+ Mak135_V%density_ak135( 40) = 11.6998000000000
+ Mak135_V%density_ak135( 41) = 11.6612000000000
+ Mak135_V%density_ak135( 42) = 11.6216000000000
+ Mak135_V%density_ak135( 43) = 11.5809000000000
+ Mak135_V%density_ak135( 44) = 11.5391000000000
+ Mak135_V%density_ak135( 45) = 11.4962000000000
+ Mak135_V%density_ak135( 46) = 11.4521000000000
+ Mak135_V%density_ak135( 47) = 11.4069000000000
+ Mak135_V%density_ak135( 48) = 11.3604000000000
+ Mak135_V%density_ak135( 49) = 11.3127000000000
+ Mak135_V%density_ak135( 50) = 11.2639000000000
+ Mak135_V%density_ak135( 51) = 11.2137000000000
+ Mak135_V%density_ak135( 52) = 11.1623000000000
+ Mak135_V%density_ak135( 53) = 11.1095000000000
+ Mak135_V%density_ak135( 54) = 11.0555000000000
+ Mak135_V%density_ak135( 55) = 11.0001000000000
+ Mak135_V%density_ak135( 56) = 10.9434000000000
+ Mak135_V%density_ak135( 57) = 10.8852000000000
+ Mak135_V%density_ak135( 58) = 10.8257000000000
+ Mak135_V%density_ak135( 59) = 10.7647000000000
+ Mak135_V%density_ak135( 60) = 10.7023000000000
+ Mak135_V%density_ak135( 61) = 10.6385000000000
+ Mak135_V%density_ak135( 62) = 10.5731000000000
+ Mak135_V%density_ak135( 63) = 10.5062000000000
+ Mak135_V%density_ak135( 64) = 10.4378000000000
+ Mak135_V%density_ak135( 65) = 10.3679000000000
+ Mak135_V%density_ak135( 66) = 10.2964000000000
+ Mak135_V%density_ak135( 67) = 10.2233000000000
+ Mak135_V%density_ak135( 68) = 10.1485000000000
+ Mak135_V%density_ak135( 69) = 10.0722000000000
+ Mak135_V%density_ak135( 70) = 9.99420000000000
+ Mak135_V%density_ak135( 71) = 9.91450000000000
+ Mak135_V%density_ak135( 72) = 5.77210000000000
+ Mak135_V%density_ak135( 73) = 5.74580000000000
+ Mak135_V%density_ak135( 74) = 5.71960000000000
+ Mak135_V%density_ak135( 75) = 5.69340000000000
+ Mak135_V%density_ak135( 76) = 5.43870000000000
+ Mak135_V%density_ak135( 77) = 5.41760000000000
+ Mak135_V%density_ak135( 78) = 5.39620000000000
+ Mak135_V%density_ak135( 79) = 5.37480000000000
+ Mak135_V%density_ak135( 80) = 5.35310000000000
+ Mak135_V%density_ak135( 81) = 5.33130000000000
+ Mak135_V%density_ak135( 82) = 5.30920000000000
+ Mak135_V%density_ak135( 83) = 5.28700000000000
+ Mak135_V%density_ak135( 84) = 5.26460000000000
+ Mak135_V%density_ak135( 85) = 5.24200000000000
+ Mak135_V%density_ak135( 86) = 5.21920000000000
+ Mak135_V%density_ak135( 87) = 5.19630000000000
+ Mak135_V%density_ak135( 88) = 5.17320000000000
+ Mak135_V%density_ak135( 89) = 5.14990000000000
+ Mak135_V%density_ak135( 90) = 5.12640000000000
+ Mak135_V%density_ak135( 91) = 5.10270000000000
+ Mak135_V%density_ak135( 92) = 5.07890000000000
+ Mak135_V%density_ak135( 93) = 5.05480000000000
+ Mak135_V%density_ak135( 94) = 5.03060000000000
+ Mak135_V%density_ak135( 95) = 5.00620000000000
+ Mak135_V%density_ak135( 96) = 4.98170000000000
+ Mak135_V%density_ak135( 97) = 4.95700000000000
+ Mak135_V%density_ak135( 98) = 4.93210000000000
+ Mak135_V%density_ak135( 99) = 4.90690000000000
+ Mak135_V%density_ak135(100) = 4.88170000000000
+ Mak135_V%density_ak135(101) = 4.85620000000000
+ Mak135_V%density_ak135(102) = 4.83070000000000
+ Mak135_V%density_ak135(103) = 4.80500000000000
+ Mak135_V%density_ak135(104) = 4.77900000000000
+ Mak135_V%density_ak135(105) = 4.75280000000000
+ Mak135_V%density_ak135(106) = 4.72660000000000
+ Mak135_V%density_ak135(107) = 4.70010000000000
+ Mak135_V%density_ak135(108) = 4.67350000000000
+ Mak135_V%density_ak135(109) = 4.64670000000000
+ Mak135_V%density_ak135(110) = 4.61980000000000
+ Mak135_V%density_ak135(111) = 4.59260000000000
+ Mak135_V%density_ak135(112) = 4.56540000000000
+ Mak135_V%density_ak135(113) = 4.51620000000000
+ Mak135_V%density_ak135(114) = 4.46500000000000
+ Mak135_V%density_ak135(115) = 4.41180000000000
+ Mak135_V%density_ak135(116) = 4.35650000000000
+ Mak135_V%density_ak135(117) = 4.29860000000000
+ Mak135_V%density_ak135(118) = 4.23870000000000
+ Mak135_V%density_ak135(119) = 3.92010000000000
+ Mak135_V%density_ak135(120) = 3.92060000000000
+ Mak135_V%density_ak135(121) = 3.92180000000000
+ Mak135_V%density_ak135(122) = 3.92330000000000
+ Mak135_V%density_ak135(123) = 3.92730000000000
+ Mak135_V%density_ak135(124) = 3.93170000000000
+ Mak135_V%density_ak135(125) = 3.50680000000000
+ Mak135_V%density_ak135(126) = 3.45770000000000
+ Mak135_V%density_ak135(127) = 3.41100000000000
+ Mak135_V%density_ak135(128) = 3.36630000000000
+ Mak135_V%density_ak135(129) = 3.32430000000000
+ Mak135_V%density_ak135(130) = 3.32430000000000
+ Mak135_V%density_ak135(131) = 3.37110000000000
+ Mak135_V%density_ak135(132) = 3.42680000000000
+ Mak135_V%density_ak135(133) = 3.50200000000000
+ Mak135_V%density_ak135(134) = 3.50200000000000
+ Mak135_V%density_ak135(135) = 3.58010000000000
+ Mak135_V%density_ak135(136) = 3.64100000000000
+ Mak135_V%density_ak135(137) = 2.92000000000000
+ Mak135_V%density_ak135(138) = 2.92000000000000
+ Mak135_V%density_ak135(139) = 2.60000000000000
+ Mak135_V%density_ak135(140) = 2.60000000000000
+ Mak135_V%density_ak135(141) = 2.60000000000000
+ Mak135_V%density_ak135(142) = 2.60000000000000
+ Mak135_V%density_ak135(143) = 2.60000000000000
+ Mak135_V%density_ak135(144) = 2.60000000000000
+
+ Mak135_V%vp_ak135( 1) = 11.2622000000000
+ Mak135_V%vp_ak135( 2) = 11.2618000000000
+ Mak135_V%vp_ak135( 3) = 11.2606000000000
+ Mak135_V%vp_ak135( 4) = 11.2586000000000
+ Mak135_V%vp_ak135( 5) = 11.2557000000000
+ Mak135_V%vp_ak135( 6) = 11.2521000000000
+ Mak135_V%vp_ak135( 7) = 11.2477000000000
+ Mak135_V%vp_ak135( 8) = 11.2424000000000
+ Mak135_V%vp_ak135( 9) = 11.2364000000000
+ Mak135_V%vp_ak135( 10) = 11.2295000000000
+ Mak135_V%vp_ak135( 11) = 11.2219000000000
+ Mak135_V%vp_ak135( 12) = 11.2134000000000
+ Mak135_V%vp_ak135( 13) = 11.2041000000000
+ Mak135_V%vp_ak135( 14) = 11.1941000000000
+ Mak135_V%vp_ak135( 15) = 11.1832000000000
+ Mak135_V%vp_ak135( 16) = 11.1715000000000
+ Mak135_V%vp_ak135( 17) = 11.1590000000000
+ Mak135_V%vp_ak135( 18) = 11.1457000000000
+ Mak135_V%vp_ak135( 19) = 11.1316000000000
+ Mak135_V%vp_ak135( 20) = 11.1166000000000
+ Mak135_V%vp_ak135( 21) = 11.0983000000000
+ Mak135_V%vp_ak135( 22) = 11.0850000000000
+ Mak135_V%vp_ak135( 23) = 11.0718000000000
+ Mak135_V%vp_ak135( 24) = 11.0585000000000
+ Mak135_V%vp_ak135( 25) = 11.0427000000000
+ Mak135_V%vp_ak135( 26) = 10.2890000000000
+ Mak135_V%vp_ak135( 27) = 10.2854000000000
+ Mak135_V%vp_ak135( 28) = 10.2745000000000
+ Mak135_V%vp_ak135( 29) = 10.2565000000000
+ Mak135_V%vp_ak135( 30) = 10.2329000000000
+ Mak135_V%vp_ak135( 31) = 10.2049000000000
+ Mak135_V%vp_ak135( 32) = 10.1739000000000
+ Mak135_V%vp_ak135( 33) = 10.1415000000000
+ Mak135_V%vp_ak135( 34) = 10.1095000000000
+ Mak135_V%vp_ak135( 35) = 10.0768000000000
+ Mak135_V%vp_ak135( 36) = 10.0439000000000
+ Mak135_V%vp_ak135( 37) = 10.0103000000000
+ Mak135_V%vp_ak135( 38) = 9.97610000000000
+ Mak135_V%vp_ak135( 39) = 9.94100000000000
+ Mak135_V%vp_ak135( 40) = 9.90510000000000
+ Mak135_V%vp_ak135( 41) = 9.86820000000000
+ Mak135_V%vp_ak135( 42) = 9.83040000000000
+ Mak135_V%vp_ak135( 43) = 9.79140000000000
+ Mak135_V%vp_ak135( 44) = 9.75130000000000
+ Mak135_V%vp_ak135( 45) = 9.71000000000000
+ Mak135_V%vp_ak135( 46) = 9.66730000000000
+ Mak135_V%vp_ak135( 47) = 9.62320000000000
+ Mak135_V%vp_ak135( 48) = 9.57770000000000
+ Mak135_V%vp_ak135( 49) = 9.53060000000000
+ Mak135_V%vp_ak135( 50) = 9.48140000000000
+ Mak135_V%vp_ak135( 51) = 9.42970000000000
+ Mak135_V%vp_ak135( 52) = 9.37600000000000
+ Mak135_V%vp_ak135( 53) = 9.32050000000000
+ Mak135_V%vp_ak135( 54) = 9.26340000000000
+ Mak135_V%vp_ak135( 55) = 9.20420000000000
+ Mak135_V%vp_ak135( 56) = 9.14260000000000
+ Mak135_V%vp_ak135( 57) = 9.07920000000000
+ Mak135_V%vp_ak135( 58) = 9.01380000000000
+ Mak135_V%vp_ak135( 59) = 8.94610000000000
+ Mak135_V%vp_ak135( 60) = 8.87610000000000
+ Mak135_V%vp_ak135( 61) = 8.80360000000000
+ Mak135_V%vp_ak135( 62) = 8.72830000000000
+ Mak135_V%vp_ak135( 63) = 8.64960000000000
+ Mak135_V%vp_ak135( 64) = 8.56920000000000
+ Mak135_V%vp_ak135( 65) = 8.48610000000000
+ Mak135_V%vp_ak135( 66) = 8.40010000000000
+ Mak135_V%vp_ak135( 67) = 8.31220000000000
+ Mak135_V%vp_ak135( 68) = 8.22130000000000
+ Mak135_V%vp_ak135( 69) = 8.12830000000000
+ Mak135_V%vp_ak135( 70) = 8.03820000000000
+ Mak135_V%vp_ak135( 71) = 8.00000000000000
+ Mak135_V%vp_ak135( 72) = 13.6601000000000
+ Mak135_V%vp_ak135( 73) = 13.6570000000000
+ Mak135_V%vp_ak135( 74) = 13.6533000000000
+ Mak135_V%vp_ak135( 75) = 13.6498000000000
+ Mak135_V%vp_ak135( 76) = 13.6498000000000
+ Mak135_V%vp_ak135( 77) = 13.5899000000000
+ Mak135_V%vp_ak135( 78) = 13.5311000000000
+ Mak135_V%vp_ak135( 79) = 13.4741000000000
+ Mak135_V%vp_ak135( 80) = 13.4156000000000
+ Mak135_V%vp_ak135( 81) = 13.3584000000000
+ Mak135_V%vp_ak135( 82) = 13.3017000000000
+ Mak135_V%vp_ak135( 83) = 13.2465000000000
+ Mak135_V%vp_ak135( 84) = 13.1895000000000
+ Mak135_V%vp_ak135( 85) = 13.1337000000000
+ Mak135_V%vp_ak135( 86) = 13.0786000000000
+ Mak135_V%vp_ak135( 87) = 13.0226000000000
+ Mak135_V%vp_ak135( 88) = 12.9663000000000
+ Mak135_V%vp_ak135( 89) = 12.9093000000000
+ Mak135_V%vp_ak135( 90) = 12.8524000000000
+ Mak135_V%vp_ak135( 91) = 12.7956000000000
+ Mak135_V%vp_ak135( 92) = 12.7384000000000
+ Mak135_V%vp_ak135( 93) = 12.6807000000000
+ Mak135_V%vp_ak135( 94) = 12.6226000000000
+ Mak135_V%vp_ak135( 95) = 12.5638000000000
+ Mak135_V%vp_ak135( 96) = 12.5030000000000
+ Mak135_V%vp_ak135( 97) = 12.4427000000000
+ Mak135_V%vp_ak135( 98) = 12.3813000000000
+ Mak135_V%vp_ak135( 99) = 12.3181000000000
+ Mak135_V%vp_ak135(100) = 12.2558000000000
+ Mak135_V%vp_ak135(101) = 12.1912000000000
+ Mak135_V%vp_ak135(102) = 12.1247000000000
+ Mak135_V%vp_ak135(103) = 12.0571000000000
+ Mak135_V%vp_ak135(104) = 11.9891000000000
+ Mak135_V%vp_ak135(105) = 11.9208000000000
+ Mak135_V%vp_ak135(106) = 11.8491000000000
+ Mak135_V%vp_ak135(107) = 11.7768000000000
+ Mak135_V%vp_ak135(108) = 11.7020000000000
+ Mak135_V%vp_ak135(109) = 11.6265000000000
+ Mak135_V%vp_ak135(110) = 11.5493000000000
+ Mak135_V%vp_ak135(111) = 11.4704000000000
+ Mak135_V%vp_ak135(112) = 11.3897000000000
+ Mak135_V%vp_ak135(113) = 11.3068000000000
+ Mak135_V%vp_ak135(114) = 11.2228000000000
+ Mak135_V%vp_ak135(115) = 11.1355000000000
+ Mak135_V%vp_ak135(116) = 11.0553000000000
+ Mak135_V%vp_ak135(117) = 10.9222000000000
+ Mak135_V%vp_ak135(118) = 10.7909000000000
+ Mak135_V%vp_ak135(119) = 10.2000000000000
+ Mak135_V%vp_ak135(120) = 10.0320000000000
+ Mak135_V%vp_ak135(121) = 9.86400000000000
+ Mak135_V%vp_ak135(122) = 9.69620000000000
+ Mak135_V%vp_ak135(123) = 9.52800000000000
+ Mak135_V%vp_ak135(124) = 9.36010000000000
+ Mak135_V%vp_ak135(125) = 9.03020000000000
+ Mak135_V%vp_ak135(126) = 8.84760000000000
+ Mak135_V%vp_ak135(127) = 8.66500000000000
+ Mak135_V%vp_ak135(128) = 8.48220000000000
+ Mak135_V%vp_ak135(129) = 8.30070000000000
+ Mak135_V%vp_ak135(130) = 8.30070000000000
+ Mak135_V%vp_ak135(131) = 8.17500000000000
+ Mak135_V%vp_ak135(132) = 8.05050000000000
+ Mak135_V%vp_ak135(133) = 8.04500000000000
+ Mak135_V%vp_ak135(134) = 8.04000000000000
+ Mak135_V%vp_ak135(135) = 8.03790000000000
+ Mak135_V%vp_ak135(136) = 8.03550000000000
+ Mak135_V%vp_ak135(137) = 6.80000000000000
+ Mak135_V%vp_ak135(138) = 6.80000000000000
+ Mak135_V%vp_ak135(139) = 5.80000000000000
+ Mak135_V%vp_ak135(140) = 5.80000000000000
+ Mak135_V%vp_ak135(141) = 5.80000000000000
+ Mak135_V%vp_ak135(142) = 5.80000000000000
+ Mak135_V%vp_ak135(143) = 5.80000000000000
+ Mak135_V%vp_ak135(144) = 5.80000000000000
+
+ Mak135_V%vs_ak135( 1) = 3.66780000000000
+ Mak135_V%vs_ak135( 2) = 3.66750000000000
+ Mak135_V%vs_ak135( 3) = 3.66670000000000
+ Mak135_V%vs_ak135( 4) = 3.66530000000000
+ Mak135_V%vs_ak135( 5) = 3.66330000000000
+ Mak135_V%vs_ak135( 6) = 3.66080000000000
+ Mak135_V%vs_ak135( 7) = 3.65770000000000
+ Mak135_V%vs_ak135( 8) = 3.65400000000000
+ Mak135_V%vs_ak135( 9) = 3.64980000000000
+ Mak135_V%vs_ak135( 10) = 3.64500000000000
+ Mak135_V%vs_ak135( 11) = 3.63960000000000
+ Mak135_V%vs_ak135( 12) = 3.63370000000000
+ Mak135_V%vs_ak135( 13) = 3.62720000000000
+ Mak135_V%vs_ak135( 14) = 3.62020000000000
+ Mak135_V%vs_ak135( 15) = 3.61260000000000
+ Mak135_V%vs_ak135( 16) = 3.60440000000000
+ Mak135_V%vs_ak135( 17) = 3.59570000000000
+ Mak135_V%vs_ak135( 18) = 3.58640000000000
+ Mak135_V%vs_ak135( 19) = 3.57650000000000
+ Mak135_V%vs_ak135( 20) = 3.56610000000000
+ Mak135_V%vs_ak135( 21) = 3.55510000000000
+ Mak135_V%vs_ak135( 22) = 3.54350000000000
+ Mak135_V%vs_ak135( 23) = 3.53140000000000
+ Mak135_V%vs_ak135( 24) = 3.51870000000000
+ Mak135_V%vs_ak135( 25) = 3.50430000000000
+ Mak135_V%vs_ak135( 26) = 0.000000000000000
+ Mak135_V%vs_ak135( 27) = 0.000000000000000
+ Mak135_V%vs_ak135( 28) = 0.000000000000000
+ Mak135_V%vs_ak135( 29) = 0.000000000000000
+ Mak135_V%vs_ak135( 30) = 0.000000000000000
+ Mak135_V%vs_ak135( 31) = 0.000000000000000
+ Mak135_V%vs_ak135( 32) = 0.000000000000000
+ Mak135_V%vs_ak135( 33) = 0.000000000000000
+ Mak135_V%vs_ak135( 34) = 0.000000000000000
+ Mak135_V%vs_ak135( 35) = 0.000000000000000
+ Mak135_V%vs_ak135( 36) = 0.000000000000000
+ Mak135_V%vs_ak135( 37) = 0.000000000000000
+ Mak135_V%vs_ak135( 38) = 0.000000000000000
+ Mak135_V%vs_ak135( 39) = 0.000000000000000
+ Mak135_V%vs_ak135( 40) = 0.000000000000000
+ Mak135_V%vs_ak135( 41) = 0.000000000000000
+ Mak135_V%vs_ak135( 42) = 0.000000000000000
+ Mak135_V%vs_ak135( 43) = 0.000000000000000
+ Mak135_V%vs_ak135( 44) = 0.000000000000000
+ Mak135_V%vs_ak135( 45) = 0.000000000000000
+ Mak135_V%vs_ak135( 46) = 0.000000000000000
+ Mak135_V%vs_ak135( 47) = 0.000000000000000
+ Mak135_V%vs_ak135( 48) = 0.000000000000000
+ Mak135_V%vs_ak135( 49) = 0.000000000000000
+ Mak135_V%vs_ak135( 50) = 0.000000000000000
+ Mak135_V%vs_ak135( 51) = 0.000000000000000
+ Mak135_V%vs_ak135( 52) = 0.000000000000000
+ Mak135_V%vs_ak135( 53) = 0.000000000000000
+ Mak135_V%vs_ak135( 54) = 0.000000000000000
+ Mak135_V%vs_ak135( 55) = 0.000000000000000
+ Mak135_V%vs_ak135( 56) = 0.000000000000000
+ Mak135_V%vs_ak135( 57) = 0.000000000000000
+ Mak135_V%vs_ak135( 58) = 0.000000000000000
+ Mak135_V%vs_ak135( 59) = 0.000000000000000
+ Mak135_V%vs_ak135( 60) = 0.000000000000000
+ Mak135_V%vs_ak135( 61) = 0.000000000000000
+ Mak135_V%vs_ak135( 62) = 0.000000000000000
+ Mak135_V%vs_ak135( 63) = 0.000000000000000
+ Mak135_V%vs_ak135( 64) = 0.000000000000000
+ Mak135_V%vs_ak135( 65) = 0.000000000000000
+ Mak135_V%vs_ak135( 66) = 0.000000000000000
+ Mak135_V%vs_ak135( 67) = 0.000000000000000
+ Mak135_V%vs_ak135( 68) = 0.000000000000000
+ Mak135_V%vs_ak135( 69) = 0.000000000000000
+ Mak135_V%vs_ak135( 70) = 0.000000000000000
+ Mak135_V%vs_ak135( 71) = 0.000000000000000
+ Mak135_V%vs_ak135( 72) = 7.28170000000000
+ Mak135_V%vs_ak135( 73) = 7.27000000000000
+ Mak135_V%vs_ak135( 74) = 7.25930000000000
+ Mak135_V%vs_ak135( 75) = 7.24850000000000
+ Mak135_V%vs_ak135( 76) = 7.24850000000000
+ Mak135_V%vs_ak135( 77) = 7.22530000000000
+ Mak135_V%vs_ak135( 78) = 7.20310000000000
+ Mak135_V%vs_ak135( 79) = 7.18040000000000
+ Mak135_V%vs_ak135( 80) = 7.15840000000000
+ Mak135_V%vs_ak135( 81) = 7.13680000000000
+ Mak135_V%vs_ak135( 82) = 7.11440000000000
+ Mak135_V%vs_ak135( 83) = 7.09320000000000
+ Mak135_V%vs_ak135( 84) = 7.07220000000000
+ Mak135_V%vs_ak135( 85) = 7.05040000000000
+ Mak135_V%vs_ak135( 86) = 7.02860000000000
+ Mak135_V%vs_ak135( 87) = 7.00690000000000
+ Mak135_V%vs_ak135( 88) = 6.98520000000000
+ Mak135_V%vs_ak135( 89) = 6.96250000000000
+ Mak135_V%vs_ak135( 90) = 6.94160000000000
+ Mak135_V%vs_ak135( 91) = 6.91940000000000
+ Mak135_V%vs_ak135( 92) = 6.89720000000000
+ Mak135_V%vs_ak135( 93) = 6.87430000000000
+ Mak135_V%vs_ak135( 94) = 6.85170000000000
+ Mak135_V%vs_ak135( 95) = 6.82890000000000
+ Mak135_V%vs_ak135( 96) = 6.80560000000000
+ Mak135_V%vs_ak135( 97) = 6.78200000000000
+ Mak135_V%vs_ak135( 98) = 6.75790000000000
+ Mak135_V%vs_ak135( 99) = 6.73230000000000
+ Mak135_V%vs_ak135(100) = 6.70700000000000
+ Mak135_V%vs_ak135(101) = 6.68130000000000
+ Mak135_V%vs_ak135(102) = 6.65540000000000
+ Mak135_V%vs_ak135(103) = 6.62850000000000
+ Mak135_V%vs_ak135(104) = 6.60090000000000
+ Mak135_V%vs_ak135(105) = 6.57280000000000
+ Mak135_V%vs_ak135(106) = 6.54310000000000
+ Mak135_V%vs_ak135(107) = 6.51310000000000
+ Mak135_V%vs_ak135(108) = 6.48220000000000
+ Mak135_V%vs_ak135(109) = 6.45140000000000
+ Mak135_V%vs_ak135(110) = 6.41820000000000
+ Mak135_V%vs_ak135(111) = 6.38600000000000
+ Mak135_V%vs_ak135(112) = 6.35190000000000
+ Mak135_V%vs_ak135(113) = 6.31640000000000
+ Mak135_V%vs_ak135(114) = 6.27990000000000
+ Mak135_V%vs_ak135(115) = 6.24240000000000
+ Mak135_V%vs_ak135(116) = 6.21000000000000
+ Mak135_V%vs_ak135(117) = 6.08980000000000
+ Mak135_V%vs_ak135(118) = 5.96070000000000
+ Mak135_V%vs_ak135(119) = 5.61040000000000
+ Mak135_V%vs_ak135(120) = 5.50470000000000
+ Mak135_V%vs_ak135(121) = 5.39890000000000
+ Mak135_V%vs_ak135(122) = 5.29220000000000
+ Mak135_V%vs_ak135(123) = 5.18640000000000
+ Mak135_V%vs_ak135(124) = 5.08060000000000
+ Mak135_V%vs_ak135(125) = 4.87020000000000
+ Mak135_V%vs_ak135(126) = 4.78320000000000
+ Mak135_V%vs_ak135(127) = 4.69640000000000
+ Mak135_V%vs_ak135(128) = 4.60940000000000
+ Mak135_V%vs_ak135(129) = 4.51840000000000
+ Mak135_V%vs_ak135(130) = 4.51840000000000
+ Mak135_V%vs_ak135(131) = 4.50900000000000
+ Mak135_V%vs_ak135(132) = 4.50000000000000
+ Mak135_V%vs_ak135(133) = 4.49000000000000
+ Mak135_V%vs_ak135(134) = 4.48000000000000
+ Mak135_V%vs_ak135(135) = 4.48560000000000
+ Mak135_V%vs_ak135(136) = 4.48390000000000
+ Mak135_V%vs_ak135(137) = 3.90000000000000
+ Mak135_V%vs_ak135(138) = 3.90000000000000
+ Mak135_V%vs_ak135(139) = 3.20000000000000
+ Mak135_V%vs_ak135(140) = 3.20000000000000
+ Mak135_V%vs_ak135(141) = 3.20000000000000
+ Mak135_V%vs_ak135(142) = 3.20000000000000
+ Mak135_V%vs_ak135(143) = 3.20000000000000
+ Mak135_V%vs_ak135(144) = 3.20000000000000
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+ Mak135_V%vp_ak135(137:144) = Mak135_V%vp_ak135(136)
+ Mak135_V%vs_ak135(137:144) = Mak135_V%vs_ak135(136)
+ Mak135_V%density_ak135(137:144) = Mak135_V%density_ak135(136)
+ endif
+
+ Mak135_V%Qkappa_ak135( 1) = 601.270000000000
+ Mak135_V%Qkappa_ak135( 2) = 601.320000000000
+ Mak135_V%Qkappa_ak135( 3) = 601.460000000000
+ Mak135_V%Qkappa_ak135( 4) = 601.700000000000
+ Mak135_V%Qkappa_ak135( 5) = 602.050000000000
+ Mak135_V%Qkappa_ak135( 6) = 602.490000000000
+ Mak135_V%Qkappa_ak135( 7) = 603.040000000000
+ Mak135_V%Qkappa_ak135( 8) = 603.690000000000
+ Mak135_V%Qkappa_ak135( 9) = 604.440000000000
+ Mak135_V%Qkappa_ak135( 10) = 605.280000000000
+ Mak135_V%Qkappa_ak135( 11) = 606.260000000000
+ Mak135_V%Qkappa_ak135( 12) = 607.310000000000
+ Mak135_V%Qkappa_ak135( 13) = 608.480000000000
+ Mak135_V%Qkappa_ak135( 14) = 609.740000000000
+ Mak135_V%Qkappa_ak135( 15) = 611.120000000000
+ Mak135_V%Qkappa_ak135( 16) = 612.620000000000
+ Mak135_V%Qkappa_ak135( 17) = 614.210000000000
+ Mak135_V%Qkappa_ak135( 18) = 615.930000000000
+ Mak135_V%Qkappa_ak135( 19) = 617.780000000000
+ Mak135_V%Qkappa_ak135( 20) = 619.710000000000
+ Mak135_V%Qkappa_ak135( 21) = 621.500000000000
+ Mak135_V%Qkappa_ak135( 22) = 624.080000000000
+ Mak135_V%Qkappa_ak135( 23) = 626.870000000000
+ Mak135_V%Qkappa_ak135( 24) = 629.890000000000
+ Mak135_V%Qkappa_ak135( 25) = 633.260000000000
+ Mak135_V%Qkappa_ak135( 26) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 27) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 28) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 29) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 30) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 31) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 32) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 33) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 34) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 35) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 36) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 37) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 38) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 39) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 40) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 41) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 42) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 43) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 44) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 45) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 46) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 47) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 48) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 49) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 50) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 51) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 52) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 53) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 54) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 55) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 56) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 57) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 58) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 59) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 60) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 61) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 62) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 63) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 64) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 65) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 66) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 67) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 68) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 69) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 70) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 71) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 72) = 723.120000000000
+ Mak135_V%Qkappa_ak135( 73) = 725.110000000000
+ Mak135_V%Qkappa_ak135( 74) = 726.870000000000
+ Mak135_V%Qkappa_ak135( 75) = 722.730000000000
+ Mak135_V%Qkappa_ak135( 76) = 933.210000000000
+ Mak135_V%Qkappa_ak135( 77) = 940.880000000000
+ Mak135_V%Qkappa_ak135( 78) = 952.000000000000
+ Mak135_V%Qkappa_ak135( 79) = 960.360000000000
+ Mak135_V%Qkappa_ak135( 80) = 968.460000000000
+ Mak135_V%Qkappa_ak135( 81) = 976.810000000000
+ Mak135_V%Qkappa_ak135( 82) = 985.630000000000
+ Mak135_V%Qkappa_ak135( 83) = 990.770000000000
+ Mak135_V%Qkappa_ak135( 84) = 999.440000000000
+ Mak135_V%Qkappa_ak135( 85) = 1008.79000000000
+ Mak135_V%Qkappa_ak135( 86) = 1018.38000000000
+ Mak135_V%Qkappa_ak135( 87) = 1032.14000000000
+ Mak135_V%Qkappa_ak135( 88) = 1042.07000000000
+ Mak135_V%Qkappa_ak135( 89) = 1048.09000000000
+ Mak135_V%Qkappa_ak135( 90) = 1058.03000000000
+ Mak135_V%Qkappa_ak135( 91) = 1064.23000000000
+ Mak135_V%Qkappa_ak135( 92) = 1070.38000000000
+ Mak135_V%Qkappa_ak135( 93) = 1085.97000000000
+ Mak135_V%Qkappa_ak135( 94) = 1097.16000000000
+ Mak135_V%Qkappa_ak135( 95) = 1108.58000000000
+ Mak135_V%Qkappa_ak135( 96) = 1120.09000000000
+ Mak135_V%Qkappa_ak135( 97) = 1127.02000000000
+ Mak135_V%Qkappa_ak135( 98) = 1134.01000000000
+ Mak135_V%Qkappa_ak135( 99) = 1141.32000000000
+ Mak135_V%Qkappa_ak135(100) = 1148.76000000000
+ Mak135_V%Qkappa_ak135(101) = 1156.04000000000
+ Mak135_V%Qkappa_ak135(102) = 1163.16000000000
+ Mak135_V%Qkappa_ak135(103) = 1170.53000000000
+ Mak135_V%Qkappa_ak135(104) = 1178.19000000000
+ Mak135_V%Qkappa_ak135(105) = 1186.06000000000
+ Mak135_V%Qkappa_ak135(106) = 1193.99000000000
+ Mak135_V%Qkappa_ak135(107) = 1202.04000000000
+ Mak135_V%Qkappa_ak135(108) = 1210.02000000000
+ Mak135_V%Qkappa_ak135(109) = 1217.91000000000
+ Mak135_V%Qkappa_ak135(110) = 1226.52000000000
+ Mak135_V%Qkappa_ak135(111) = 1234.54000000000
+ Mak135_V%Qkappa_ak135(112) = 1243.02000000000
+ Mak135_V%Qkappa_ak135(113) = 1251.69000000000
+ Mak135_V%Qkappa_ak135(114) = 1260.68000000000
+ Mak135_V%Qkappa_ak135(115) = 1269.44000000000
+ Mak135_V%Qkappa_ak135(116) = 1277.93000000000
+ Mak135_V%Qkappa_ak135(117) = 1311.17000000000
+ Mak135_V%Qkappa_ak135(118) = 1350.54000000000
+ Mak135_V%Qkappa_ak135(119) = 428.690000000000
+ Mak135_V%Qkappa_ak135(120) = 425.510000000000
+ Mak135_V%Qkappa_ak135(121) = 422.550000000000
+ Mak135_V%Qkappa_ak135(122) = 419.940000000000
+ Mak135_V%Qkappa_ak135(123) = 417.320000000000
+ Mak135_V%Qkappa_ak135(124) = 413.660000000000
+ Mak135_V%Qkappa_ak135(125) = 377.930000000000
+ Mak135_V%Qkappa_ak135(126) = 366.340000000000
+ Mak135_V%Qkappa_ak135(127) = 355.850000000000
+ Mak135_V%Qkappa_ak135(128) = 346.370000000000
+ Mak135_V%Qkappa_ak135(129) = 338.470000000000
+ Mak135_V%Qkappa_ak135(130) = 200.970000000000
+ Mak135_V%Qkappa_ak135(131) = 188.720000000000
+ Mak135_V%Qkappa_ak135(132) = 182.570000000000
+ Mak135_V%Qkappa_ak135(133) = 182.030000000000
+ Mak135_V%Qkappa_ak135(134) = 1008.71000000000
+ Mak135_V%Qkappa_ak135(135) = 972.770000000000
+ Mak135_V%Qkappa_ak135(136) = 950.500000000000
+ Mak135_V%Qkappa_ak135(137) = 1368.02000000000
+ Mak135_V%Qkappa_ak135(138) = 1368.02000000000
+ Mak135_V%Qkappa_ak135(139) = 1478.30000000000
+ Mak135_V%Qkappa_ak135(140) = 1478.30000000000
+ Mak135_V%Qkappa_ak135(141) = 1478.30000000000
+ Mak135_V%Qkappa_ak135(142) = 1478.30000000000
+ Mak135_V%Qkappa_ak135(143) = 1478.30000000000
+ Mak135_V%Qkappa_ak135(144) = 1478.30000000000
+
+ Mak135_V%Qmu_ak135( 1) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 2) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 3) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 4) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 5) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 6) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 7) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 8) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 9) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 10) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 11) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 12) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 13) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 14) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 15) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 16) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 17) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 18) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 19) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 20) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 21) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 22) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 23) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 24) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 25) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 26) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 27) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 28) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 29) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 30) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 31) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 32) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 33) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 34) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 35) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 36) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 37) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 38) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 39) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 40) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 41) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 42) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 43) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 44) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 45) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 46) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 47) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 48) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 49) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 50) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 51) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 52) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 53) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 54) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 55) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 56) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 57) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 58) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 59) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 60) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 61) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 62) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 63) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 64) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 65) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 66) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 67) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 68) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 69) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 70) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 71) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 72) = 273.970000000000
+ Mak135_V%Qmu_ak135( 73) = 273.970000000000
+ Mak135_V%Qmu_ak135( 74) = 273.970000000000
+ Mak135_V%Qmu_ak135( 75) = 271.740000000000
+ Mak135_V%Qmu_ak135( 76) = 350.880000000000
+ Mak135_V%Qmu_ak135( 77) = 354.610000000000
+ Mak135_V%Qmu_ak135( 78) = 359.710000000000
+ Mak135_V%Qmu_ak135( 79) = 363.640000000000
+ Mak135_V%Qmu_ak135( 80) = 367.650000000000
+ Mak135_V%Qmu_ak135( 81) = 371.750000000000
+ Mak135_V%Qmu_ak135( 82) = 375.940000000000
+ Mak135_V%Qmu_ak135( 83) = 378.790000000000
+ Mak135_V%Qmu_ak135( 84) = 383.140000000000
+ Mak135_V%Qmu_ak135( 85) = 387.600000000000
+ Mak135_V%Qmu_ak135( 86) = 392.160000000000
+ Mak135_V%Qmu_ak135( 87) = 398.410000000000
+ Mak135_V%Qmu_ak135( 88) = 403.230000000000
+ Mak135_V%Qmu_ak135( 89) = 406.500000000000
+ Mak135_V%Qmu_ak135( 90) = 411.520000000000
+ Mak135_V%Qmu_ak135( 91) = 414.940000000000
+ Mak135_V%Qmu_ak135( 92) = 418.410000000000
+ Mak135_V%Qmu_ak135( 93) = 425.530000000000
+ Mak135_V%Qmu_ak135( 94) = 431.030000000000
+ Mak135_V%Qmu_ak135( 95) = 436.680000000000
+ Mak135_V%Qmu_ak135( 96) = 442.480000000000
+ Mak135_V%Qmu_ak135( 97) = 446.430000000000
+ Mak135_V%Qmu_ak135( 98) = 450.450000000000
+ Mak135_V%Qmu_ak135( 99) = 454.550000000000
+ Mak135_V%Qmu_ak135(100) = 458.720000000000
+ Mak135_V%Qmu_ak135(101) = 462.960000000000
+ Mak135_V%Qmu_ak135(102) = 467.290000000000
+ Mak135_V%Qmu_ak135(103) = 471.700000000000
+ Mak135_V%Qmu_ak135(104) = 476.190000000000
+ Mak135_V%Qmu_ak135(105) = 480.770000000000
+ Mak135_V%Qmu_ak135(106) = 485.440000000000
+ Mak135_V%Qmu_ak135(107) = 490.200000000000
+ Mak135_V%Qmu_ak135(108) = 495.050000000000
+ Mak135_V%Qmu_ak135(109) = 500.000000000000
+ Mak135_V%Qmu_ak135(110) = 505.050000000000
+ Mak135_V%Qmu_ak135(111) = 510.200000000000
+ Mak135_V%Qmu_ak135(112) = 515.460000000000
+ Mak135_V%Qmu_ak135(113) = 520.830000000000
+ Mak135_V%Qmu_ak135(114) = 526.320000000000
+ Mak135_V%Qmu_ak135(115) = 531.910000000000
+ Mak135_V%Qmu_ak135(116) = 537.630000000000
+ Mak135_V%Qmu_ak135(117) = 543.480000000000
+ Mak135_V%Qmu_ak135(118) = 549.450000000000
+ Mak135_V%Qmu_ak135(119) = 172.930000000000
+ Mak135_V%Qmu_ak135(120) = 170.820000000000
+ Mak135_V%Qmu_ak135(121) = 168.780000000000
+ Mak135_V%Qmu_ak135(122) = 166.800000000000
+ Mak135_V%Qmu_ak135(123) = 164.870000000000
+ Mak135_V%Qmu_ak135(124) = 162.500000000000
+ Mak135_V%Qmu_ak135(125) = 146.570000000000
+ Mak135_V%Qmu_ak135(126) = 142.760000000000
+ Mak135_V%Qmu_ak135(127) = 139.380000000000
+ Mak135_V%Qmu_ak135(128) = 136.380000000000
+ Mak135_V%Qmu_ak135(129) = 133.720000000000
+ Mak135_V%Qmu_ak135(130) = 79.4000000000000
+ Mak135_V%Qmu_ak135(131) = 76.5500000000000
+ Mak135_V%Qmu_ak135(132) = 76.0600000000000
+ Mak135_V%Qmu_ak135(133) = 75.6000000000000
+ Mak135_V%Qmu_ak135(134) = 417.590000000000
+ Mak135_V%Qmu_ak135(135) = 403.930000000000
+ Mak135_V%Qmu_ak135(136) = 394.620000000000
+ Mak135_V%Qmu_ak135(137) = 599.990000000000
+ Mak135_V%Qmu_ak135(138) = 599.990000000000
+ Mak135_V%Qmu_ak135(139) = 599.990000000000
+ Mak135_V%Qmu_ak135(140) = 599.990000000000
+ Mak135_V%Qmu_ak135(141) = 599.990000000000
+ Mak135_V%Qmu_ak135(142) = 599.990000000000
+ Mak135_V%Qmu_ak135(143) = 599.990000000000
+ Mak135_V%Qmu_ak135(144) = 599.990000000000
+
+! strip the crust and replace it by mantle
+ if(USE_EXTERNAL_CRUSTAL_MODEL) then
+ do i=NR_AK135-8,NR_AK135
+ Mak135_V%density_ak135(i) = Mak135_V%density_ak135(NR_AK135-9)
+ Mak135_V%vp_ak135(i) = Mak135_V%vp_ak135(NR_AK135-9)
+ Mak135_V%vs_ak135(i) = Mak135_V%vs_ak135(NR_AK135-9)
+ Mak135_V%Qkappa_ak135(i) = Mak135_V%Qkappa_ak135(NR_AK135-9)
+ Mak135_V%Qmu_ak135(i) = Mak135_V%Qmu_ak135(NR_AK135-9)
+ enddo
+ endif
+
+ end subroutine define_model_ak135
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_iasp91.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_iasp91.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_iasp91.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_iasp91.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,229 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_doubling_flag, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST)
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ logical check_doubling_flag
+
+ integer idoubling,myrank
+
+ double precision x,rho,vp,vs,Qkappa,Qmu,RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST
+
+ logical ONE_CRUST
+
+ double precision r,scaleval
+
+ double precision x1,x2
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+ x1 = R120 / R_EARTH
+ x2 = RMOHO / R_EARTH
+
+! check flags to make sure we correctly honor the discontinuities
+! we use strict inequalities since r has been slighly changed in mesher
+
+ if(check_doubling_flag) then
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r < RICB) then
+ if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
+ idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
+ call exit_MPI(myrank,'wrong doubling flag for inner core point')
+!
+!--- outer core
+!
+ else if(r > RICB .and. r < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for outer core point')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for D" point')
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
+
+!
+!--- mantle: from d670 to d220
+!
+ else if(r > R670 .and. r < R220) then
+ if(idoubling /= IFLAG_670_220) &
+ call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
+
+!
+!--- mantle and crust: from d220 to MOHO and then to surface
+!
+ else if(r > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
+ call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
+
+ endif
+
+ endif
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r <= RICB) then
+ rho=13.0885d0-8.8381d0*x*x
+ vp=11.24094-4.09689*x**2
+ vs=3.56454-3.45241*x**2
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if(r > RICB .and. r <= RCMB) then
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vp=10.03904+3.75665*x-13.67046*x**2
+ vs=0.0d0
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=14.49470-1.47089*x
+ vs=8.16616-1.58206*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=25.1486-41.1538*x+51.9932*x**2-26.6083*x**3
+ vs=12.9303-21.2590*x+27.8988*x**2-14.1080*x**3
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=25.96984-16.93412*x
+ vs=20.76890-16.53147*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= R400) then
+ rho=5.3197d0-1.4836d0*x
+ vp=29.38896-21.40656*x
+ vs=17.70732-13.50652*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R400 .and. r <= R220) then
+ rho=7.1089d0-3.8045d0*x
+ vp=30.78765-23.25415*x
+ vs=15.24213-11.08552*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+
+! from Sebastien Chevrot: for the IASP91 model
+! Depth R Vp Vs
+! 0-20 6351-6371 5.80 3.36
+! 20-35 6336-6351 6.50 3.75
+! 35-120 6251-6336 8.78541-0.74953 x 6.706231-2.248585 x
+! with x = r / 6371
+
+ else if(r > R220 .and. r <= R120) then
+ rho=2.6910d0+0.6924d0*x
+ vp=25.41389-17.69722*x
+ vs=5.75020-1.27420*x
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+
+ else if(r > R120 .and. r <= RMOHO) then
+ vp = 8.78541d0-0.74953d0*x
+ vs = 6.706231d0-2.248585d0*x
+ rho = 3.3713d0 + (3.3198d0-3.3713d0)*(x-x1)/(x2-x1)
+ if(rho < 3.30d0 .or. rho > 3.38d0) stop 'incorrect density computed for IASP91'
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ else if (SUPPRESS_CRUSTAL_MESH) then
+!! DK DK extend the Moho up to the surface instead of the crust
+ vp = 8.78541d0-0.74953d0*(RMOHO / R_EARTH)
+ vs = 6.706231d0-2.248585d0*(RMOHO / R_EARTH)
+ rho = 3.3198d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ vp = 6.5d0
+ vs = 3.75d0
+ rho = 2.92d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! same properties everywhere in PREM crust if we decide to define only one layer in the crust
+ if(ONE_CRUST) then
+ vp = 5.8d0
+ vs = 3.36d0
+ rho = 2.72d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+ else
+ vp = 5.8d0
+ vs = 3.36d0
+ rho = 2.72d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine model_iasp91
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_jp1d.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_jp1d.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_jp1d.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_jp1d.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,204 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 model_jp1d(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling, &
+ check_doubling_flag,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
+
+ implicit none
+
+ include "constants.h"
+
+ ! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ logical check_doubling_flag
+ integer idoubling,myrank
+
+ double precision x,rho,vp,vs,Qkappa,Qmu,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST
+
+ double precision r
+ double precision scaleval
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+! check flags to make sure we correctly honor the discontinuities
+! we use strict inequalities since r has been slighly changed in mesher
+
+ if(check_doubling_flag) then
+
+!--- inner core
+!
+ if(r >= 0.d0 .and. r < RICB) then
+ if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
+ idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
+ call exit_MPI(myrank,'wrong doubling flag for inner core point')
+!
+!--- outer core
+!
+ else if(r > RICB .and. r < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for outer core point')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for D" point')
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
+
+!
+!--- mantle: from d670 to d220
+!
+ else if(r > R670 .and. r < R220) then
+ if(idoubling /= IFLAG_670_220) &
+ call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
+
+!
+!--- mantle and crust: from d220 to MOHO and then to surface
+!
+ else if(r > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
+ call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
+
+ endif
+
+ endif
+
+
+!
+!--- inner core
+!
+ if (r >= 0.d0 .and. r <= RICB) then
+ rho=13.0885d0-8.8381d0*x*x
+ vp=11.24094-4.09689*x**2
+ vs=3.56454-3.45241*x**2
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if (r > RICB .and. r <= RCMB) then
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vp=10.03904+3.75665*x-13.67046*x**2
+ vs=0.0d0
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+!
+!--- D" at the base of the mantle
+!
+ else if (r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=14.49470-1.47089*x
+ vs=8.16616-1.58206*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=-355.58324*x**4 + 1002.03178*x**3 - 1057.3873425*x**2 + 487.0891011*x - 68.520645
+ vs=-243.33862*x**4 + 668.06411*x**3 - 685.20113*x**2 + 308.04893*x - 43.737642
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=-174.468866*x**2 + 286.37769*x - 106.034798
+ vs=-81.0865*x*x + 129.67095*x - 45.268933
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= 5871000.d0) then
+ vp=-300.510146*x*x + 511.17372648*x - 206.265832
+ vs=-139.78275*x*x + 233.3097462*x - 91.0129372
+ rho=3.3d0 + (vs-4.4d0)*0.7d0
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+
+ else if(r > 5871000.d0 .and. r <= R400) then
+ vp=-601.0202917*x*x + 1063.3823*x - 459.9388738
+ vs=-145.2465705*x*x + 243.2807524*x - 95.561877
+ rho=3.3d0 + (vs - 4.4d0)*0.7d0
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+
+ else if(r > R400 .and. r <= R220) then
+ vp=25.042512155*x*x - 68.8367583*x + 51.4120272
+ vs=15.540158021*x*x - 40.2087657*x + 28.9578929
+ rho=3.3d0 + (vs - 4.4d0)*0.7d0
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+
+ else if(r > R220 .and. r <= R80) then
+ vp=27.0989608 - 19.473338*x
+ vs=13.920596 - 9.6309917*x
+ rho=3.3d0 + (vs - 4.4d0)*0.7d0
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+
+ else if(r > R80 .and. r <= RMOHO) then
+ vp=26.7663028 - 19.13645*x
+ vs=13.4601434 - 9.164683*x
+ rho=3.3d0 + (vs - 4.4d0)*0.7d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ rho=2.9d0
+ vp = 6.7d0
+ vs = 3.8d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ else
+ rho=2.6d0
+ vp = 6.0d0
+ vs = 3.5d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ end if
+
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+end subroutine model_jp1d
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_prem.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_prem.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_prem.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_prem.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,612 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, &
+ ONE_CRUST,check_doubling_flag,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ logical CRUSTAL,ONE_CRUST,check_doubling_flag
+
+ integer idoubling,myrank
+
+ double precision x,rho,drhodr,vp,vs,Qkappa,Qmu,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ double precision r,scaleval
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+! check flags to make sure we correctly honor the discontinuities
+! we use strict inequalities since r has been slighly changed in mesher
+
+ if(check_doubling_flag) then
+
+!
+!--- inner core
+!
+
+ if(r >= 0.d0 .and. r < RICB) then
+ if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
+ idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
+ call exit_MPI(myrank,'wrong doubling flag for inner core point')
+!
+!--- outer core
+!
+ else if(r > RICB .and. r < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for outer core point')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for D" point')
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
+
+!
+!--- mantle: from d670 to d220
+!
+ else if(r > R670 .and. r < R220) then
+ if(idoubling /= IFLAG_670_220) &
+ call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
+
+!
+!--- mantle and crust: from d220 to MOHO and then to surface
+!
+ else if(r > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
+ call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
+
+ endif
+
+ endif
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r <= RICB) then
+ drhodr=-2.0d0*8.8381d0*x
+ rho=13.0885d0-8.8381d0*x*x
+ vp=11.2622d0-6.3640d0*x*x
+ vs=3.6678d0-4.4475d0*x*x
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if(r > RICB .and. r <= RCMB) then
+ drhodr=-1.2638d0-2.0d0*3.6426d0*x-3.0d0*5.5281d0*x*x
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vp=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
+ vs=0.0d0
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=15.3891d0-5.3181d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vs=6.9254d0+1.4672d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=24.9520d0-40.4673d0*x+51.4832d0*x*x-26.6419d0*x*x*x
+ vs=11.1671d0-13.7818d0*x+17.4575d0*x*x-9.2777d0*x*x*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=29.2766d0-23.6027d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vs=22.3459d0-17.2473d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= R600) then
+ drhodr=-1.4836d0
+ rho=5.3197d0-1.4836d0*x
+ vp=19.0957d0-9.8672d0*x
+ vs=9.9839d0-4.9324d0*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R600 .and. r <= R400) then
+ drhodr=-8.0298d0
+ rho=11.2494d0-8.0298d0*x
+ vp=39.7027d0-32.6166d0*x
+ vs=22.3512d0-18.5856d0*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R400 .and. r <= R220) then
+ drhodr=-3.8045d0
+ rho=7.1089d0-3.8045d0*x
+ vp=20.3926d0-12.2569d0*x
+ vs=8.9496d0-4.4597d0*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R220 .and. r <= R80) then
+ drhodr=0.6924d0
+ rho=2.6910d0+0.6924d0*x
+ vp=4.1875d0+3.9382d0*x
+ vs=2.1519d0+2.3481d0*x
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+ else
+ if(CRUSTAL .and. .not. SUPPRESS_CRUSTAL_MESH) then
+! fill with PREM mantle and later add CRUST2.0
+ if(r > R80) then
+ drhodr=0.6924d0
+ rho=2.6910d0+0.6924d0*x
+ vp=4.1875d0+3.9382d0*x
+ vs=2.1519d0+2.3481d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+ else
+! use PREM crust
+ if(r > R80 .and. r <= RMOHO) then
+ drhodr=0.6924d0
+ rho=2.6910d0+0.6924d0*x
+ vp=4.1875d0+3.9382d0*x
+ vs=2.1519d0+2.3481d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+
+ else if (SUPPRESS_CRUSTAL_MESH) then
+!! DK DK extend the Moho up to the surface instead of the crust
+ drhodr=0.6924d0
+ rho = 2.6910d0+0.6924d0*(RMOHO / R_EARTH)
+ vp = 4.1875d0+3.9382d0*(RMOHO / R_EARTH)
+ vs = 2.1519d0+2.3481d0*(RMOHO / R_EARTH)
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ drhodr=0.0d0
+ rho=2.9d0
+ vp=6.8d0
+ vs=3.9d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! same properties everywhere in PREM crust if we decide to define only one layer in the crust
+ if(ONE_CRUST) then
+ drhodr=0.0d0
+ rho=2.6d0
+ vp=5.8d0
+ vs=3.2d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+ else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
+ drhodr=0.0d0
+ rho=2.6d0
+ vp=5.8d0
+ vs=3.2d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+! for density profile for gravity, we do not check that r <= R_EARTH
+ else if(r > ROCEAN) then
+ drhodr=0.0d0
+ rho=2.6d0
+ vp=5.8d0
+ vs=3.2d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ endif
+ endif
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ drhodr=drhodr*1000.0d0/RHOAV
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine prem_iso
+
+!
+!=====================================================================
+!
+
+ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, &
+ idoubling,CRUSTAL,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ logical CRUSTAL,ONE_CRUST
+
+ integer idoubling,myrank
+
+ double precision x,rho,Qkappa,Qmu,vpv,vph,vsv,vsh,eta_aniso,RICB,RCMB, &
+ RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ double precision r
+ double precision scaleval
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+! check flags to make sure we correctly honor the discontinuities
+! we use strict inequalities since r has been slighly changed in mesher
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r < RICB) then
+ if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
+ idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
+ call exit_MPI(myrank,'wrong doubling flag for inner core point')
+!
+!--- outer core
+!
+ else if(r > RICB .and. r < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for outer core point')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for D" point')
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
+
+!
+!--- mantle: from d670 to d220
+!
+ else if(r > R670 .and. r < R220) then
+ if(idoubling /= IFLAG_670_220) &
+ call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
+
+!
+!--- mantle and crust: from d220 to MOHO and then to surface
+!
+ else if(r > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
+ call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
+
+ endif
+
+! no anisotropy by default
+ eta_aniso = 1.d0
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r <= RICB) then
+ rho=13.0885d0-8.8381d0*x*x
+ vpv=11.2622d0-6.3640d0*x*x
+ vsv=3.6678d0-4.4475d0*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if(r > RICB .and. r <= RCMB) then
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vpv=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
+ vsv=0.0d0
+ vph=vpv
+ vsh=vsv
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vpv=15.3891d0-5.3181d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vsv=6.9254d0+1.4672d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vpv=24.9520d0-40.4673d0*x+51.4832d0*x*x-26.6419d0*x*x*x
+ vsv=11.1671d0-13.7818d0*x+17.4575d0*x*x-9.2777d0*x*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vpv=29.2766d0-23.6027d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vsv=22.3459d0-17.2473d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= R600) then
+ rho=5.3197d0-1.4836d0*x
+ vpv=19.0957d0-9.8672d0*x
+ vsv=9.9839d0-4.9324d0*x
+ vph=vpv
+ vsh=vsv
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R600 .and. r <= R400) then
+ rho=11.2494d0-8.0298d0*x
+ vpv=39.7027d0-32.6166d0*x
+ vsv=22.3512d0-18.5856d0*x
+ vph=vpv
+ vsh=vsv
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R400 .and. r <= R220) then
+ rho=7.1089d0-3.8045d0*x
+ vpv=20.3926d0-12.2569d0*x
+ vsv=8.9496d0-4.4597d0*x
+ vph=vpv
+ vsh=vsv
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R220 .and. r <= R80) then
+
+! anisotropy in PREM only above 220 km
+
+ rho=2.6910d0+0.6924d0*x
+ vpv=0.8317d0+7.2180d0*x
+ vph=3.5908d0+4.6172d0*x
+ vsv=5.8582d0-1.4678d0*x
+ vsh=-1.0839d0+5.7176d0*x
+ eta_aniso=3.3687d0-2.4778d0*x
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+
+ else
+ if(CRUSTAL) then
+! fill with PREM mantle and later add CRUST2.0
+ if(r > R80) then
+ rho=2.6910d0+0.6924d0*x
+ vpv=0.8317d0+7.2180d0*x
+ vph=3.5908d0+4.6172d0*x
+ vsv=5.8582d0-1.4678d0*x
+ vsh=-1.0839d0+5.7176d0*x
+ eta_aniso=3.3687d0-2.4778d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+ else
+! use PREM crust
+ if(r > R80 .and. r <= RMOHO) then
+
+! anisotropy in PREM only above 220 km
+
+ rho=2.6910d0+0.6924d0*x
+ vpv=0.8317d0+7.2180d0*x
+ vph=3.5908d0+4.6172d0*x
+ vsv=5.8582d0-1.4678d0*x
+ vsh=-1.0839d0+5.7176d0*x
+ eta_aniso=3.3687d0-2.4778d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! no anisotropy in the crust in PREM
+
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ rho=2.9d0
+ vpv=6.8d0
+ vsv=3.9d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! same properties everywhere in PREM crust (only one layer in the crust)
+ if(ONE_CRUST) then
+ rho=2.6d0
+ vpv=5.8d0
+ vsv=3.2d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+ else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
+ rho=2.6d0
+ vpv=5.8d0
+ vsv=3.2d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ else if(r > ROCEAN) then
+ rho=2.6d0
+ vpv=5.8d0
+ vsv=3.2d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+ endif
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+! do not scale anisotropy parameter eta_aniso, which is dimensionless
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vpv=vpv*1000.0d0/(R_EARTH*scaleval)
+ vsv=vsv*1000.0d0/(R_EARTH*scaleval)
+ vph=vph*1000.0d0/(R_EARTH*scaleval)
+ vsh=vsh*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine prem_aniso
+
+!
+!=====================================================================
+!
+
+ subroutine prem_display_outer_core(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling)
+
+! routine used for AVS or DX display of stability condition
+! and number of points per wavelength only in the fluid outer core
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ integer idoubling,myrank
+ double precision x,rho,vp,vs,Qkappa,Qmu
+
+ double precision scaleval
+
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) call exit_MPI(myrank,'wrong doubling flag for outer core point')
+
+!
+!--- outer core
+!
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vp=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
+ vs=0.0d0
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+ rho = rho*1000.0d0/RHOAV
+ vp = vp*1000.0d0/(R_EARTH*scaleval)
+ vs = vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine prem_display_outer_core
+
+!
+!=====================================================================
+!
+
+ subroutine prem_density(x,rho,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision x,rho,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ logical ONE_CRUST
+
+ double precision r
+
+ r = x * R_EARTH
+
+ if(r <= RICB) then
+ rho=13.0885d0-8.8381d0*x*x
+ else if(r > RICB .and. r <= RCMB) then
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ else if(r > R771 .and. r <= R670) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ else if(r > R670 .and. r <= R600) then
+ rho=5.3197d0-1.4836d0*x
+ else if(r > R600 .and. r <= R400) then
+ rho=11.2494d0-8.0298d0*x
+ else if(r > R400 .and. r <= R220) then
+ rho=7.1089d0-3.8045d0*x
+ else if(r > R220 .and. r <= R80) then
+ rho=2.6910d0+0.6924d0*x
+ else
+ if(r > R80 .and. r <= RMOHO) then
+ rho=2.6910d0+0.6924d0*x
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ if(ONE_CRUST) then
+ rho=2.6d0
+ else
+ rho=2.9d0
+ endif
+ else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
+ rho=2.6d0
+ else if(r > ROCEAN) then
+ rho=2.6d0
+ endif
+ endif
+
+ rho=rho*1000.0d0/RHOAV
+
+ end subroutine prem_density
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_ref.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ref.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_ref.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_ref.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,7374 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 model_ref(x,rho,vpv,vph,vsv,vsh,eta,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+! input:
+! dimensionless radius x
+
+! output: non-dimensionalized
+! mass density rho
+! compressional wave speed vpv
+! compressional wave speed vph
+! shear wave speed vsv
+! shear wave speed vsh
+! dimensionless parameter eta
+! shear quality factor Qmu
+! bulk quality factor Qkappa
+
+ integer iregion_code
+
+ double precision x,rho,vpv,vph,vsv,vsh,eta,Qmu,Qkappa
+
+ integer i
+
+ double precision r,frac,scaleval
+ logical CRUSTAL
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+ i = 1
+ do while(r >= Mref_V%radius_ref(i) .and. i /= NR_REF)
+ i = i + 1
+ enddo
+
+! make sure we stay in the right region
+ if(iregion_code == IREGION_INNER_CORE .and. i > 180) i = 180
+
+ if(iregion_code == IREGION_OUTER_CORE .and. i < 182) i = 182
+ if(iregion_code == IREGION_OUTER_CORE .and. i > 358) i = 358
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. i < 360) i = 360
+ if(CRUSTAL .and. i > 717) i = 717
+
+
+ if(i == 1) then
+ rho = Mref_V%density_ref(i)
+ vpv = Mref_V%vpv_ref(i)
+ vph = Mref_V%vph_ref(i)
+ vsv = Mref_V%vsv_ref(i)
+ vsh = Mref_V%vsh_ref(i)
+ eta = Mref_V%eta_ref(i)
+ Qkappa = Mref_V%Qkappa_ref(i)
+ Qmu = Mref_V%Qmu_ref(i)
+ else
+
+! interpolate from radius_ref(i-1) to r using the values at i-1 and i
+ frac = (r-Mref_V%radius_ref(i-1))/(Mref_V%radius_ref(i)-Mref_V%radius_ref(i-1))
+
+ rho = Mref_V%density_ref(i-1) + frac * (Mref_V%density_ref(i)-Mref_V%density_ref(i-1))
+ vpv = Mref_V%vpv_ref(i-1) + frac * (Mref_V%vpv_ref(i)-Mref_V%vpv_ref(i-1))
+ vph = Mref_V%vph_ref(i-1) + frac * (Mref_V%vph_ref(i)-Mref_V%vph_ref(i-1))
+ vsv = Mref_V%vsv_ref(i-1) + frac * (Mref_V%vsv_ref(i)-Mref_V%vsv_ref(i-1))
+ vsh = Mref_V%vsh_ref(i-1) + frac * (Mref_V%vsh_ref(i)-Mref_V%vsh_ref(i-1))
+ eta = Mref_V%eta_ref(i-1) + frac * (Mref_V%eta_ref(i)-Mref_V%eta_ref(i-1))
+ Qkappa = Mref_V%Qkappa_ref(i-1) + frac * (Mref_V%Qkappa_ref(i)-Mref_V%Qkappa_ref(i-1))
+ Qmu = Mref_V%Qmu_ref(i-1) + frac * (Mref_V%Qmu_ref(i)-Mref_V%Qmu_ref(i-1))
+
+ endif
+
+! make sure Vs is zero in the outer core even if roundoff errors on depth
+! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
+ if(iregion_code == IREGION_OUTER_CORE) then
+ vsv = 0.d0
+ vsh = 0.d0
+ Qkappa = 3000.d0
+ Qmu = 3000.d0
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho/RHOAV
+ vpv=vpv/(R_EARTH*scaleval)
+ vph=vph/(R_EARTH*scaleval)
+ vsv=vsv/(R_EARTH*scaleval)
+ vsh=vsh/(R_EARTH*scaleval)
+
+ end subroutine model_ref
+
+!-------------------
+
+ subroutine define_model_ref(Mref_V)
+
+ implicit none
+ include "constants.h"
+
+! 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
+
+
+! define the 1D REF model of Kustowski et al. (2007)
+
+ Mref_V%radius_ref( 1 : 30 ) = (/ &
+ 0.000000000000000E+000 , &
+ 6824.00000000000 , &
+ 13648.0000000000 , &
+ 20472.0000000000 , &
+ 27296.0000000000 , &
+ 34120.0000000000 , &
+ 40944.0000000000 , &
+ 47768.0000000000 , &
+ 54592.0000000000 , &
+ 61416.0000000000 , &
+ 68240.0000000000 , &
+ 75064.0000000000 , &
+ 81888.0000000000 , &
+ 88712.0000000000 , &
+ 95536.0000000000 , &
+ 102360.000000000 , &
+ 109184.000000000 , &
+ 116007.000000000 , &
+ 122831.000000000 , &
+ 129655.000000000 , &
+ 136479.000000000 , &
+ 143303.000000000 , &
+ 150127.000000000 , &
+ 156951.000000000 , &
+ 163775.000000000 , &
+ 170599.000000000 , &
+ 177423.000000000 , &
+ 184247.000000000 , &
+ 191071.000000000 , &
+ 197895.000000000 /)
+
+ Mref_V%radius_ref( 31 : 60 ) = (/ &
+ 204719.000000000 , &
+ 211543.000000000 , &
+ 218367.000000000 , &
+ 225191.000000000 , &
+ 232015.000000000 , &
+ 238839.000000000 , &
+ 245663.000000000 , &
+ 252487.000000000 , &
+ 259311.000000000 , &
+ 266135.000000000 , &
+ 272959.000000000 , &
+ 279783.000000000 , &
+ 286607.000000000 , &
+ 293431.000000000 , &
+ 300255.000000000 , &
+ 307079.000000000 , &
+ 313903.000000000 , &
+ 320727.000000000 , &
+ 327551.000000000 , &
+ 334375.000000000 , &
+ 341199.000000000 , &
+ 348022.000000000 , &
+ 354846.000000000 , &
+ 361670.000000000 , &
+ 368494.000000000 , &
+ 375318.000000000 , &
+ 382142.000000000 , &
+ 388966.000000000 , &
+ 395790.000000000 , &
+ 402614.000000000 /)
+
+ Mref_V%radius_ref( 61 : 90 ) = (/ &
+ 409438.000000000 , &
+ 416262.000000000 , &
+ 423086.000000000 , &
+ 429910.000000000 , &
+ 436734.000000000 , &
+ 443558.000000000 , &
+ 450382.000000000 , &
+ 457206.000000000 , &
+ 464030.000000000 , &
+ 470854.000000000 , &
+ 477678.000000000 , &
+ 484502.000000000 , &
+ 491326.000000000 , &
+ 498150.000000000 , &
+ 504974.000000000 , &
+ 511798.000000000 , &
+ 518622.000000000 , &
+ 525446.000000000 , &
+ 532270.000000000 , &
+ 539094.000000000 , &
+ 545918.000000000 , &
+ 552742.000000000 , &
+ 559566.000000000 , &
+ 566390.000000000 , &
+ 573214.000000000 , &
+ 580037.000000000 , &
+ 586861.000000000 , &
+ 593685.000000000 , &
+ 600509.000000000 , &
+ 607333.000000000 /)
+
+ Mref_V%radius_ref( 91 : 120 ) = (/ &
+ 614157.000000000 , &
+ 620981.000000000 , &
+ 627805.000000000 , &
+ 634629.000000000 , &
+ 641453.000000000 , &
+ 648277.000000000 , &
+ 655101.000000000 , &
+ 661925.000000000 , &
+ 668749.000000000 , &
+ 675573.000000000 , &
+ 682397.000000000 , &
+ 689221.000000000 , &
+ 696045.000000000 , &
+ 702869.000000000 , &
+ 709693.000000000 , &
+ 716517.000000000 , &
+ 723341.000000000 , &
+ 730165.000000000 , &
+ 736989.000000000 , &
+ 743813.000000000 , &
+ 750637.000000000 , &
+ 757461.000000000 , &
+ 764285.000000000 , &
+ 771109.000000000 , &
+ 777933.000000000 , &
+ 784757.000000000 , &
+ 791581.000000000 , &
+ 798405.000000000 , &
+ 805229.000000000 , &
+ 812052.000000000 /)
+
+ Mref_V%radius_ref( 121 : 150 ) = (/ &
+ 818876.000000000 , &
+ 825700.000000000 , &
+ 832524.000000000 , &
+ 839348.000000000 , &
+ 846172.000000000 , &
+ 852996.000000000 , &
+ 859820.000000000 , &
+ 866644.000000000 , &
+ 873468.000000000 , &
+ 880292.000000000 , &
+ 887116.000000000 , &
+ 893940.000000000 , &
+ 900764.000000000 , &
+ 907588.000000000 , &
+ 914412.000000000 , &
+ 921236.000000000 , &
+ 928060.000000000 , &
+ 934884.000000000 , &
+ 941708.000000000 , &
+ 948532.000000000 , &
+ 955356.000000000 , &
+ 962180.000000000 , &
+ 969004.000000000 , &
+ 975828.000000000 , &
+ 982652.000000000 , &
+ 989476.000000000 , &
+ 996300.000000000 , &
+ 1003124.00000000 , &
+ 1009948.00000000 , &
+ 1016772.00000000 /)
+
+ Mref_V%radius_ref( 151 : 180 ) = (/ &
+ 1023596.00000000 , &
+ 1030420.00000000 , &
+ 1037244.00000000 , &
+ 1044067.00000000 , &
+ 1050891.00000000 , &
+ 1057715.00000000 , &
+ 1064539.00000000 , &
+ 1071363.00000000 , &
+ 1078187.00000000 , &
+ 1085011.00000000 , &
+ 1091835.00000000 , &
+ 1098659.00000000 , &
+ 1105483.00000000 , &
+ 1112307.00000000 , &
+ 1119131.00000000 , &
+ 1125955.00000000 , &
+ 1132779.00000000 , &
+ 1139603.00000000 , &
+ 1146427.00000000 , &
+ 1153251.00000000 , &
+ 1160075.00000000 , &
+ 1166899.00000000 , &
+ 1173723.00000000 , &
+ 1180547.00000000 , &
+ 1187371.00000000 , &
+ 1194195.00000000 , &
+ 1201019.00000000 , &
+ 1207843.00000000 , &
+ 1214667.00000000 , &
+ 1221491.00000000 /)
+
+ Mref_V%radius_ref( 181 : 210 ) = (/ &
+ 1221491.00000000 , &
+ 1234250.00000000 , &
+ 1247010.00000000 , &
+ 1259770.00000000 , &
+ 1272530.00000000 , &
+ 1285289.00000000 , &
+ 1298049.00000000 , &
+ 1310809.00000000 , &
+ 1323568.00000000 , &
+ 1336328.00000000 , &
+ 1349088.00000000 , &
+ 1361847.00000000 , &
+ 1374607.00000000 , &
+ 1387367.00000000 , &
+ 1400127.00000000 , &
+ 1412886.00000000 , &
+ 1425646.00000000 , &
+ 1438406.00000000 , &
+ 1451165.00000000 , &
+ 1463925.00000000 , &
+ 1476685.00000000 , &
+ 1489444.00000000 , &
+ 1502204.00000000 , &
+ 1514964.00000000 , &
+ 1527724.00000000 , &
+ 1540483.00000000 , &
+ 1553243.00000000 , &
+ 1566003.00000000 , &
+ 1578762.00000000 , &
+ 1591522.00000000 /)
+
+ Mref_V%radius_ref( 211 : 240 ) = (/ &
+ 1604282.00000000 , &
+ 1617041.00000000 , &
+ 1629801.00000000 , &
+ 1642561.00000000 , &
+ 1655321.00000000 , &
+ 1668080.00000000 , &
+ 1680840.00000000 , &
+ 1693600.00000000 , &
+ 1706359.00000000 , &
+ 1719119.00000000 , &
+ 1731879.00000000 , &
+ 1744638.00000000 , &
+ 1757398.00000000 , &
+ 1770158.00000000 , &
+ 1782918.00000000 , &
+ 1795677.00000000 , &
+ 1808437.00000000 , &
+ 1821197.00000000 , &
+ 1833956.00000000 , &
+ 1846716.00000000 , &
+ 1859476.00000000 , &
+ 1872235.00000000 , &
+ 1884995.00000000 , &
+ 1897755.00000000 , &
+ 1910515.00000000 , &
+ 1923274.00000000 , &
+ 1936034.00000000 , &
+ 1948794.00000000 , &
+ 1961553.00000000 , &
+ 1974313.00000000 /)
+
+ Mref_V%radius_ref( 241 : 270 ) = (/ &
+ 1987073.00000000 , &
+ 1999832.00000000 , &
+ 2012592.00000000 , &
+ 2025352.00000000 , &
+ 2038112.00000000 , &
+ 2050871.00000000 , &
+ 2063631.00000000 , &
+ 2076391.00000000 , &
+ 2089150.00000000 , &
+ 2101910.00000000 , &
+ 2114670.00000000 , &
+ 2127429.00000000 , &
+ 2140189.00000000 , &
+ 2152949.00000000 , &
+ 2165709.00000000 , &
+ 2178468.00000000 , &
+ 2191228.00000000 , &
+ 2203988.00000000 , &
+ 2216747.00000000 , &
+ 2229507.00000000 , &
+ 2242267.00000000 , &
+ 2255026.00000000 , &
+ 2267786.00000000 , &
+ 2280546.00000000 , &
+ 2293306.00000000 , &
+ 2306065.00000000 , &
+ 2318825.00000000 , &
+ 2331585.00000000 , &
+ 2344344.00000000 , &
+ 2357104.00000000 /)
+
+ Mref_V%radius_ref( 271 : 300 ) = (/ &
+ 2369864.00000000 , &
+ 2382623.00000000 , &
+ 2395383.00000000 , &
+ 2408143.00000000 , &
+ 2420903.00000000 , &
+ 2433662.00000000 , &
+ 2446422.00000000 , &
+ 2459182.00000000 , &
+ 2471941.00000000 , &
+ 2484701.00000000 , &
+ 2497461.00000000 , &
+ 2510220.00000000 , &
+ 2522980.00000000 , &
+ 2535740.00000000 , &
+ 2548500.00000000 , &
+ 2561259.00000000 , &
+ 2574019.00000000 , &
+ 2586779.00000000 , &
+ 2599538.00000000 , &
+ 2612298.00000000 , &
+ 2625058.00000000 , &
+ 2637818.00000000 , &
+ 2650577.00000000 , &
+ 2663337.00000000 , &
+ 2676097.00000000 , &
+ 2688856.00000000 , &
+ 2701616.00000000 , &
+ 2714376.00000000 , &
+ 2727135.00000000 , &
+ 2739895.00000000 /)
+
+ Mref_V%radius_ref( 301 : 330 ) = (/ &
+ 2752655.00000000 , &
+ 2765415.00000000 , &
+ 2778174.00000000 , &
+ 2790934.00000000 , &
+ 2803694.00000000 , &
+ 2816453.00000000 , &
+ 2829213.00000000 , &
+ 2841973.00000000 , &
+ 2854732.00000000 , &
+ 2867492.00000000 , &
+ 2880252.00000000 , &
+ 2893012.00000000 , &
+ 2905771.00000000 , &
+ 2918531.00000000 , &
+ 2931291.00000000 , &
+ 2944050.00000000 , &
+ 2956810.00000000 , &
+ 2969570.00000000 , &
+ 2982329.00000000 , &
+ 2995089.00000000 , &
+ 3007849.00000000 , &
+ 3020609.00000000 , &
+ 3033368.00000000 , &
+ 3046128.00000000 , &
+ 3058888.00000000 , &
+ 3071647.00000000 , &
+ 3084407.00000000 , &
+ 3097167.00000000 , &
+ 3109926.00000000 , &
+ 3122686.00000000 /)
+
+ Mref_V%radius_ref( 331 : 360 ) = (/ &
+ 3135446.00000000 , &
+ 3148206.00000000 , &
+ 3160965.00000000 , &
+ 3173725.00000000 , &
+ 3186485.00000000 , &
+ 3199244.00000000 , &
+ 3212004.00000000 , &
+ 3224764.00000000 , &
+ 3237523.00000000 , &
+ 3250283.00000000 , &
+ 3263043.00000000 , &
+ 3275803.00000000 , &
+ 3288562.00000000 , &
+ 3301322.00000000 , &
+ 3314082.00000000 , &
+ 3326841.00000000 , &
+ 3339601.00000000 , &
+ 3352361.00000000 , &
+ 3365120.00000000 , &
+ 3377880.00000000 , &
+ 3390640.00000000 , &
+ 3403400.00000000 , &
+ 3416159.00000000 , &
+ 3428919.00000000 , &
+ 3441679.00000000 , &
+ 3454438.00000000 , &
+ 3467198.00000000 , &
+ 3479958.00000000 , &
+ 3479958.00000000 , &
+ 3489335.00000000 /)
+
+ Mref_V%radius_ref( 361 : 390 ) = (/ &
+ 3498713.00000000 , &
+ 3508091.00000000 , &
+ 3517468.00000000 , &
+ 3526846.00000000 , &
+ 3536224.00000000 , &
+ 3545601.00000000 , &
+ 3554979.00000000 , &
+ 3564357.00000000 , &
+ 3573734.00000000 , &
+ 3583112.00000000 , &
+ 3592489.00000000 , &
+ 3601867.00000000 , &
+ 3611245.00000000 , &
+ 3620622.00000000 , &
+ 3630000.00000000 , &
+ 3630000.00000000 , &
+ 3639471.00000000 , &
+ 3648942.00000000 , &
+ 3658413.00000000 , &
+ 3667885.00000000 , &
+ 3677356.00000000 , &
+ 3686827.00000000 , &
+ 3696298.00000000 , &
+ 3705769.00000000 , &
+ 3715240.00000000 , &
+ 3724712.00000000 , &
+ 3734183.00000000 , &
+ 3743654.00000000 , &
+ 3753125.00000000 , &
+ 3762596.00000000 /)
+
+ Mref_V%radius_ref( 391 : 420 ) = (/ &
+ 3772067.00000000 , &
+ 3781538.00000000 , &
+ 3791010.00000000 , &
+ 3800481.00000000 , &
+ 3809952.00000000 , &
+ 3819423.00000000 , &
+ 3828894.00000000 , &
+ 3838365.00000000 , &
+ 3847837.00000000 , &
+ 3857308.00000000 , &
+ 3866779.00000000 , &
+ 3876250.00000000 , &
+ 3885721.00000000 , &
+ 3895192.00000000 , &
+ 3904663.00000000 , &
+ 3914135.00000000 , &
+ 3923606.00000000 , &
+ 3933077.00000000 , &
+ 3942548.00000000 , &
+ 3952019.00000000 , &
+ 3961490.00000000 , &
+ 3970962.00000000 , &
+ 3980433.00000000 , &
+ 3989904.00000000 , &
+ 3999375.00000000 , &
+ 4008846.00000000 , &
+ 4018317.00000000 , &
+ 4027788.00000000 , &
+ 4037260.00000000 , &
+ 4046731.00000000 /)
+
+ Mref_V%radius_ref( 421 : 450 ) = (/ &
+ 4056202.00000000 , &
+ 4065673.00000000 , &
+ 4075144.00000000 , &
+ 4084615.00000000 , &
+ 4094087.00000000 , &
+ 4103558.00000000 , &
+ 4113029.00000000 , &
+ 4122500.00000000 , &
+ 4131971.00000000 , &
+ 4141442.00000000 , &
+ 4150913.00000000 , &
+ 4160385.00000000 , &
+ 4169856.00000000 , &
+ 4179327.00000000 , &
+ 4188798.00000000 , &
+ 4198269.00000000 , &
+ 4207740.00000000 , &
+ 4217212.00000000 , &
+ 4226683.00000000 , &
+ 4236154.00000000 , &
+ 4245625.00000000 , &
+ 4255096.00000000 , &
+ 4264567.00000000 , &
+ 4274038.00000000 , &
+ 4283510.00000000 , &
+ 4292981.00000000 , &
+ 4302452.00000000 , &
+ 4311923.00000000 , &
+ 4321394.00000000 , &
+ 4330865.00000000 /)
+
+ Mref_V%radius_ref( 451 : 480 ) = (/ &
+ 4340337.00000000 , &
+ 4349808.00000000 , &
+ 4359279.00000000 , &
+ 4368750.00000000 , &
+ 4378221.00000000 , &
+ 4387692.00000000 , &
+ 4397163.00000000 , &
+ 4406635.00000000 , &
+ 4416106.00000000 , &
+ 4425577.00000000 , &
+ 4435048.00000000 , &
+ 4444519.00000000 , &
+ 4453990.00000000 , &
+ 4463462.00000000 , &
+ 4472933.00000000 , &
+ 4482404.00000000 , &
+ 4491875.00000000 , &
+ 4501346.00000000 , &
+ 4510817.00000000 , &
+ 4520288.00000000 , &
+ 4529760.00000000 , &
+ 4539231.00000000 , &
+ 4548702.00000000 , &
+ 4558173.00000000 , &
+ 4567644.00000000 , &
+ 4577115.00000000 , &
+ 4586587.00000000 , &
+ 4596058.00000000 , &
+ 4605529.00000000 , &
+ 4615000.00000000 /)
+
+ Mref_V%radius_ref( 481 : 510 ) = (/ &
+ 4624471.00000000 , &
+ 4633942.00000000 , &
+ 4643413.00000000 , &
+ 4652885.00000000 , &
+ 4662356.00000000 , &
+ 4671827.00000000 , &
+ 4681298.00000000 , &
+ 4690769.00000000 , &
+ 4700240.00000000 , &
+ 4709712.00000000 , &
+ 4719183.00000000 , &
+ 4728654.00000000 , &
+ 4738125.00000000 , &
+ 4747596.00000000 , &
+ 4757067.00000000 , &
+ 4766538.00000000 , &
+ 4776010.00000000 , &
+ 4785481.00000000 , &
+ 4794952.00000000 , &
+ 4804423.00000000 , &
+ 4813894.00000000 , &
+ 4823365.00000000 , &
+ 4832837.00000000 , &
+ 4842308.00000000 , &
+ 4851779.00000000 , &
+ 4861250.00000000 , &
+ 4870721.00000000 , &
+ 4880192.00000000 , &
+ 4889663.00000000 , &
+ 4899135.00000000 /)
+
+ Mref_V%radius_ref( 511 : 540 ) = (/ &
+ 4908606.00000000 , &
+ 4918077.00000000 , &
+ 4927548.00000000 , &
+ 4937019.00000000 , &
+ 4946490.00000000 , &
+ 4955962.00000000 , &
+ 4965433.00000000 , &
+ 4974904.00000000 , &
+ 4984375.00000000 , &
+ 4993846.00000000 , &
+ 5003317.00000000 , &
+ 5012788.00000000 , &
+ 5022260.00000000 , &
+ 5031731.00000000 , &
+ 5041202.00000000 , &
+ 5050673.00000000 , &
+ 5060144.00000000 , &
+ 5069615.00000000 , &
+ 5079087.00000000 , &
+ 5088558.00000000 , &
+ 5098029.00000000 , &
+ 5107500.00000000 , &
+ 5116971.00000000 , &
+ 5126442.00000000 , &
+ 5135913.00000000 , &
+ 5145385.00000000 , &
+ 5154856.00000000 , &
+ 5164327.00000000 , &
+ 5173798.00000000 , &
+ 5183269.00000000 /)
+
+ Mref_V%radius_ref( 541 : 570 ) = (/ &
+ 5192740.00000000 , &
+ 5202212.00000000 , &
+ 5211683.00000000 , &
+ 5221154.00000000 , &
+ 5230625.00000000 , &
+ 5240096.00000000 , &
+ 5249567.00000000 , &
+ 5259038.00000000 , &
+ 5268510.00000000 , &
+ 5277981.00000000 , &
+ 5287452.00000000 , &
+ 5296923.00000000 , &
+ 5306394.00000000 , &
+ 5315865.00000000 , &
+ 5325337.00000000 , &
+ 5334808.00000000 , &
+ 5344279.00000000 , &
+ 5353750.00000000 , &
+ 5363221.00000000 , &
+ 5372692.00000000 , &
+ 5382163.00000000 , &
+ 5391635.00000000 , &
+ 5401106.00000000 , &
+ 5410577.00000000 , &
+ 5420048.00000000 , &
+ 5429519.00000000 , &
+ 5438990.00000000 , &
+ 5448462.00000000 , &
+ 5457933.00000000 , &
+ 5467404.00000000 /)
+
+ Mref_V%radius_ref( 571 : 600 ) = (/ &
+ 5476875.00000000 , &
+ 5486346.00000000 , &
+ 5495817.00000000 , &
+ 5505288.00000000 , &
+ 5514760.00000000 , &
+ 5524231.00000000 , &
+ 5533702.00000000 , &
+ 5543173.00000000 , &
+ 5552644.00000000 , &
+ 5562115.00000000 , &
+ 5571587.00000000 , &
+ 5581058.00000000 , &
+ 5590529.00000000 , &
+ 5600000.00000000 , &
+ 5600000.00000000 , &
+ 5607562.00000000 , &
+ 5615125.00000000 , &
+ 5622688.00000000 , &
+ 5630250.00000000 , &
+ 5637812.00000000 , &
+ 5645375.00000000 , &
+ 5652938.00000000 , &
+ 5660500.00000000 , &
+ 5668062.00000000 , &
+ 5675625.00000000 , &
+ 5683188.00000000 , &
+ 5690750.00000000 , &
+ 5698312.00000000 , &
+ 5705875.00000000 , &
+ 5713438.00000000 /)
+
+ Mref_V%radius_ref( 601 : 630 ) = (/ &
+ 5721000.00000000 , &
+ 5721000.00000000 , &
+ 5724572.00000000 , &
+ 5728143.00000000 , &
+ 5731714.00000000 , &
+ 5735286.00000000 , &
+ 5738857.00000000 , &
+ 5742428.00000000 , &
+ 5746000.00000000 , &
+ 5749572.00000000 , &
+ 5753143.00000000 , &
+ 5756714.00000000 , &
+ 5760286.00000000 , &
+ 5763857.00000000 , &
+ 5767428.00000000 , &
+ 5771000.00000000 , &
+ 5771000.00000000 , &
+ 5777334.00000000 , &
+ 5783666.00000000 , &
+ 5790000.00000000 , &
+ 5796334.00000000 , &
+ 5802666.00000000 , &
+ 5809000.00000000 , &
+ 5815334.00000000 , &
+ 5821666.00000000 , &
+ 5828000.00000000 , &
+ 5834334.00000000 , &
+ 5840666.00000000 , &
+ 5847000.00000000 , &
+ 5853334.00000000 /)
+
+ Mref_V%radius_ref( 631 : 660 ) = (/ &
+ 5859666.00000000 , &
+ 5866000.00000000 , &
+ 5872334.00000000 , &
+ 5878666.00000000 , &
+ 5885000.00000000 , &
+ 5891334.00000000 , &
+ 5897666.00000000 , &
+ 5904000.00000000 , &
+ 5910334.00000000 , &
+ 5916666.00000000 , &
+ 5923000.00000000 , &
+ 5929334.00000000 , &
+ 5935666.00000000 , &
+ 5942000.00000000 , &
+ 5948334.00000000 , &
+ 5954666.00000000 , &
+ 5961000.00000000 , &
+ 5961000.00000000 , &
+ 5967334.00000000 , &
+ 5973666.00000000 , &
+ 5980000.00000000 , &
+ 5986334.00000000 , &
+ 5992666.00000000 , &
+ 5999000.00000000 , &
+ 6005334.00000000 , &
+ 6011666.00000000 , &
+ 6018000.00000000 , &
+ 6024334.00000000 , &
+ 6030666.00000000 , &
+ 6037000.00000000 /)
+
+ Mref_V%radius_ref( 661 : 690 ) = (/ &
+ 6043334.00000000 , &
+ 6049666.00000000 , &
+ 6056000.00000000 , &
+ 6062334.00000000 , &
+ 6068666.00000000 , &
+ 6075000.00000000 , &
+ 6081334.00000000 , &
+ 6087666.00000000 , &
+ 6094000.00000000 , &
+ 6100334.00000000 , &
+ 6106666.00000000 , &
+ 6113000.00000000 , &
+ 6119334.00000000 , &
+ 6125666.00000000 , &
+ 6132000.00000000 , &
+ 6138334.00000000 , &
+ 6144666.00000000 , &
+ 6151000.00000000 , &
+ 6151000.00000000 , &
+ 6157087.00000000 , &
+ 6163174.00000000 , &
+ 6169261.00000000 , &
+ 6175348.00000000 , &
+ 6181435.00000000 , &
+ 6187522.00000000 , &
+ 6193609.00000000 , &
+ 6199696.00000000 , &
+ 6205783.00000000 , &
+ 6211870.00000000 , &
+ 6217957.00000000 /)
+
+ Mref_V%radius_ref( 691 : 720 ) = (/ &
+ 6224043.00000000 , &
+ 6230130.00000000 , &
+ 6236217.00000000 , &
+ 6242304.00000000 , &
+ 6248391.00000000 , &
+ 6254478.00000000 , &
+ 6260565.00000000 , &
+ 6266652.00000000 , &
+ 6272739.00000000 , &
+ 6278826.00000000 , &
+ 6284913.00000000 , &
+ 6291000.00000000 , &
+ 6291000.00000000 , &
+ 6294971.00000000 , &
+ 6298943.00000000 , &
+ 6302914.00000000 , &
+ 6306886.00000000 , &
+ 6310857.00000000 , &
+ 6314829.00000000 , &
+ 6318800.00000000 , &
+ 6322771.00000000 , &
+ 6326743.00000000 , &
+ 6330714.00000000 , &
+ 6334686.00000000 , &
+ 6338657.00000000 , &
+ 6342629.00000000 , &
+ 6346600.00000000 , &
+ 6346600.00000000 , &
+ 6347540.00000000 , &
+ 6348480.00000000 /)
+
+ Mref_V%radius_ref( 721 : 750 ) = (/ &
+ 6349420.00000000 , &
+ 6350360.00000000 , &
+ 6351300.00000000 , &
+ 6352240.00000000 , &
+ 6353180.00000000 , &
+ 6354120.00000000 , &
+ 6355060.00000000 , &
+ 6356000.00000000 , &
+ 6356000.00000000 , &
+ 6357200.00000000 , &
+ 6358400.00000000 , &
+ 6359600.00000000 , &
+ 6360800.00000000 , &
+ 6362000.00000000 , &
+ 6363200.00000000 , &
+ 6364400.00000000 , &
+ 6365600.00000000 , &
+ 6366800.00000000 , &
+ 6368000.00000000 , &
+ 6368000.00000000 , &
+ 6368300.00000000 , &
+ 6368600.00000000 , &
+ 6368900.00000000 , &
+ 6369200.00000000 , &
+ 6369500.00000000 , &
+ 6369800.00000000 , &
+ 6370100.00000000 , &
+ 6370400.00000000 , &
+ 6370700.00000000 , &
+ 6371000.00000000 /)
+
+ Mref_V%density_ref( 1 : 30 ) = (/ &
+ 13088.4800000000 , &
+ 13088.4700000000 , &
+ 13088.4400000000 , &
+ 13088.3900000000 , &
+ 13088.3200000000 , &
+ 13088.2200000000 , &
+ 13088.1100000000 , &
+ 13087.9800000000 , &
+ 13087.8300000000 , &
+ 13087.6600000000 , &
+ 13087.4600000000 , &
+ 13087.2500000000 , &
+ 13087.0200000000 , &
+ 13086.7600000000 , &
+ 13086.4900000000 , &
+ 13086.2000000000 , &
+ 13085.8800000000 , &
+ 13085.5500000000 , &
+ 13085.1900000000 , &
+ 13084.8200000000 , &
+ 13084.4200000000 , &
+ 13084.0100000000 , &
+ 13083.5700000000 , &
+ 13083.1100000000 , &
+ 13082.6400000000 , &
+ 13082.1400000000 , &
+ 13081.6200000000 , &
+ 13081.0900000000 , &
+ 13080.5300000000 , &
+ 13079.9500000000 /)
+
+ Mref_V%density_ref( 31 : 60 ) = (/ &
+ 13079.3500000000 , &
+ 13078.7300000000 , &
+ 13078.0900000000 , &
+ 13077.4400000000 , &
+ 13076.7600000000 , &
+ 13076.0600000000 , &
+ 13075.3400000000 , &
+ 13074.6000000000 , &
+ 13073.8400000000 , &
+ 13073.0600000000 , &
+ 13072.2500000000 , &
+ 13071.4300000000 , &
+ 13070.5900000000 , &
+ 13069.7300000000 , &
+ 13068.8500000000 , &
+ 13067.9500000000 , &
+ 13067.0200000000 , &
+ 13066.0800000000 , &
+ 13065.1200000000 , &
+ 13064.1300000000 , &
+ 13063.1300000000 , &
+ 13062.1000000000 , &
+ 13061.0600000000 , &
+ 13060.0000000000 , &
+ 13058.9100000000 , &
+ 13057.8100000000 , &
+ 13056.6800000000 , &
+ 13055.5300000000 , &
+ 13054.3700000000 , &
+ 13053.1800000000 /)
+
+ Mref_V%density_ref( 61 : 90 ) = (/ &
+ 13051.9800000000 , &
+ 13050.7500000000 , &
+ 13049.5000000000 , &
+ 13048.2300000000 , &
+ 13046.9500000000 , &
+ 13045.6400000000 , &
+ 13044.3100000000 , &
+ 13042.9600000000 , &
+ 13041.5900000000 , &
+ 13040.2000000000 , &
+ 13038.7900000000 , &
+ 13037.3600000000 , &
+ 13035.9100000000 , &
+ 13034.4400000000 , &
+ 13032.9500000000 , &
+ 13031.4400000000 , &
+ 13029.9100000000 , &
+ 13028.3600000000 , &
+ 13026.7900000000 , &
+ 13025.2000000000 , &
+ 13023.5800000000 , &
+ 13021.9500000000 , &
+ 13020.3000000000 , &
+ 13018.6300000000 , &
+ 13016.9300000000 , &
+ 13015.2200000000 , &
+ 13013.4900000000 , &
+ 13011.7300000000 , &
+ 13009.9600000000 , &
+ 13008.1600000000 /)
+
+ Mref_V%density_ref( 91 : 120 ) = (/ &
+ 13006.3500000000 , &
+ 13004.5100000000 , &
+ 13002.6600000000 , &
+ 13000.7800000000 , &
+ 12998.8800000000 , &
+ 12996.9700000000 , &
+ 12995.0300000000 , &
+ 12993.0700000000 , &
+ 12991.1000000000 , &
+ 12989.1000000000 , &
+ 12987.0800000000 , &
+ 12985.0400000000 , &
+ 12982.9900000000 , &
+ 12980.9100000000 , &
+ 12978.8100000000 , &
+ 12976.6900000000 , &
+ 12974.5500000000 , &
+ 12972.3900000000 , &
+ 12970.2100000000 , &
+ 12968.0100000000 , &
+ 12965.7900000000 , &
+ 12963.5500000000 , &
+ 12961.2900000000 , &
+ 12959.0100000000 , &
+ 12956.7000000000 , &
+ 12954.3800000000 , &
+ 12952.0400000000 , &
+ 12949.6800000000 , &
+ 12947.2900000000 , &
+ 12944.8900000000 /)
+
+ Mref_V%density_ref( 121 : 150 ) = (/ &
+ 12942.4700000000 , &
+ 12940.0200000000 , &
+ 12937.5600000000 , &
+ 12935.0800000000 , &
+ 12932.5700000000 , &
+ 12930.0500000000 , &
+ 12927.5000000000 , &
+ 12924.9400000000 , &
+ 12922.3500000000 , &
+ 12919.7500000000 , &
+ 12917.1200000000 , &
+ 12914.4700000000 , &
+ 12911.8100000000 , &
+ 12909.1200000000 , &
+ 12906.4100000000 , &
+ 12903.6800000000 , &
+ 12900.9400000000 , &
+ 12898.1700000000 , &
+ 12895.3800000000 , &
+ 12892.5700000000 , &
+ 12889.7400000000 , &
+ 12886.8900000000 , &
+ 12884.0200000000 , &
+ 12881.1300000000 , &
+ 12878.2200000000 , &
+ 12875.2900000000 , &
+ 12872.3400000000 , &
+ 12869.3700000000 , &
+ 12866.3800000000 , &
+ 12863.3700000000 /)
+
+ Mref_V%density_ref( 151 : 180 ) = (/ &
+ 12860.3400000000 , &
+ 12857.2900000000 , &
+ 12854.2100000000 , &
+ 12851.1200000000 , &
+ 12848.0100000000 , &
+ 12844.8800000000 , &
+ 12841.7200000000 , &
+ 12838.5500000000 , &
+ 12835.3500000000 , &
+ 12832.1400000000 , &
+ 12828.9100000000 , &
+ 12825.6500000000 , &
+ 12822.3800000000 , &
+ 12819.0800000000 , &
+ 12815.7600000000 , &
+ 12812.4300000000 , &
+ 12809.0700000000 , &
+ 12805.7000000000 , &
+ 12802.3000000000 , &
+ 12798.8800000000 , &
+ 12795.4400000000 , &
+ 12791.9900000000 , &
+ 12788.5100000000 , &
+ 12785.0100000000 , &
+ 12781.4900000000 , &
+ 12777.9500000000 , &
+ 12774.4000000000 , &
+ 12770.8200000000 , &
+ 12767.2200000000 , &
+ 12763.6000000000 /)
+
+ Mref_V%density_ref( 181 : 210 ) = (/ &
+ 12166.3500000000 , &
+ 12159.7700000000 , &
+ 12153.1400000000 , &
+ 12146.4500000000 , &
+ 12139.7100000000 , &
+ 12132.9100000000 , &
+ 12126.0500000000 , &
+ 12119.1400000000 , &
+ 12112.1800000000 , &
+ 12105.1500000000 , &
+ 12098.0700000000 , &
+ 12090.9300000000 , &
+ 12083.7300000000 , &
+ 12076.4800000000 , &
+ 12069.1700000000 , &
+ 12061.8000000000 , &
+ 12054.3700000000 , &
+ 12046.8800000000 , &
+ 12039.3300000000 , &
+ 12031.7200000000 , &
+ 12024.0500000000 , &
+ 12016.3300000000 , &
+ 12008.5400000000 , &
+ 12000.6900000000 , &
+ 11992.7800000000 , &
+ 11984.8100000000 , &
+ 11976.7800000000 , &
+ 11968.6800000000 , &
+ 11960.5300000000 , &
+ 11952.3100000000 /)
+
+ Mref_V%density_ref( 211 : 240 ) = (/ &
+ 11944.0300000000 , &
+ 11935.6900000000 , &
+ 11927.2800000000 , &
+ 11918.8100000000 , &
+ 11910.2800000000 , &
+ 11901.6800000000 , &
+ 11893.0200000000 , &
+ 11884.3000000000 , &
+ 11875.5100000000 , &
+ 11866.6600000000 , &
+ 11857.7400000000 , &
+ 11848.7500000000 , &
+ 11839.7000000000 , &
+ 11830.5800000000 , &
+ 11821.4000000000 , &
+ 11812.1500000000 , &
+ 11802.8400000000 , &
+ 11793.4500000000 , &
+ 11784.0100000000 , &
+ 11774.4900000000 , &
+ 11764.9000000000 , &
+ 11755.2500000000 , &
+ 11745.5300000000 , &
+ 11735.7400000000 , &
+ 11725.8800000000 , &
+ 11715.9500000000 , &
+ 11705.9500000000 , &
+ 11695.8900000000 , &
+ 11685.7500000000 , &
+ 11675.5400000000 /)
+
+ Mref_V%density_ref( 241 : 270 ) = (/ &
+ 11665.2600000000 , &
+ 11654.9200000000 , &
+ 11644.5000000000 , &
+ 11634.0100000000 , &
+ 11623.4400000000 , &
+ 11612.8100000000 , &
+ 11602.1000000000 , &
+ 11591.3200000000 , &
+ 11580.4700000000 , &
+ 11569.5500000000 , &
+ 11558.5500000000 , &
+ 11547.4800000000 , &
+ 11536.3400000000 , &
+ 11525.1200000000 , &
+ 11513.8300000000 , &
+ 11502.4600000000 , &
+ 11491.0200000000 , &
+ 11479.5100000000 , &
+ 11467.9100000000 , &
+ 11456.2500000000 , &
+ 11444.5000000000 , &
+ 11432.6900000000 , &
+ 11420.7900000000 , &
+ 11408.8200000000 , &
+ 11396.7700000000 , &
+ 11384.6400000000 , &
+ 11372.4400000000 , &
+ 11360.1600000000 , &
+ 11347.8000000000 , &
+ 11335.3700000000 /)
+
+ Mref_V%density_ref( 271 : 300 ) = (/ &
+ 11322.8500000000 , &
+ 11310.2600000000 , &
+ 11297.5800000000 , &
+ 11284.8300000000 , &
+ 11272.0000000000 , &
+ 11259.0900000000 , &
+ 11246.1000000000 , &
+ 11233.0300000000 , &
+ 11219.8700000000 , &
+ 11206.6400000000 , &
+ 11193.3300000000 , &
+ 11179.9300000000 , &
+ 11166.4500000000 , &
+ 11152.8900000000 , &
+ 11139.2500000000 , &
+ 11125.5300000000 , &
+ 11111.7200000000 , &
+ 11097.8300000000 , &
+ 11083.8600000000 , &
+ 11069.8000000000 , &
+ 11055.6600000000 , &
+ 11041.4400000000 , &
+ 11027.1300000000 , &
+ 11012.7400000000 , &
+ 10998.2600000000 , &
+ 10983.7000000000 , &
+ 10969.0500000000 , &
+ 10954.3200000000 , &
+ 10939.5000000000 , &
+ 10924.5900000000 /)
+
+ Mref_V%density_ref( 301 : 330 ) = (/ &
+ 10909.6000000000 , &
+ 10894.5200000000 , &
+ 10879.3500000000 , &
+ 10864.1000000000 , &
+ 10848.7600000000 , &
+ 10833.3300000000 , &
+ 10817.8100000000 , &
+ 10802.2100000000 , &
+ 10786.5100000000 , &
+ 10770.7300000000 , &
+ 10754.8600000000 , &
+ 10738.9000000000 , &
+ 10722.8500000000 , &
+ 10706.7100000000 , &
+ 10690.4800000000 , &
+ 10674.1600000000 , &
+ 10657.7500000000 , &
+ 10641.2400000000 , &
+ 10624.6500000000 , &
+ 10607.9600000000 , &
+ 10591.1900000000 , &
+ 10574.3200000000 , &
+ 10557.3600000000 , &
+ 10540.3000000000 , &
+ 10523.1600000000 , &
+ 10505.9200000000 , &
+ 10488.5800000000 , &
+ 10471.1500000000 , &
+ 10453.6300000000 , &
+ 10436.0200000000 /)
+
+ Mref_V%density_ref( 331 : 360 ) = (/ &
+ 10418.3100000000 , &
+ 10400.5100000000 , &
+ 10382.6100000000 , &
+ 10364.6100000000 , &
+ 10346.5200000000 , &
+ 10328.3400000000 , &
+ 10310.0500000000 , &
+ 10291.6800000000 , &
+ 10273.2000000000 , &
+ 10254.6300000000 , &
+ 10235.9600000000 , &
+ 10217.2000000000 , &
+ 10198.3300000000 , &
+ 10179.3700000000 , &
+ 10160.3100000000 , &
+ 10141.1500000000 , &
+ 10121.9000000000 , &
+ 10102.5400000000 , &
+ 10083.0900000000 , &
+ 10063.5300000000 , &
+ 10043.8800000000 , &
+ 10024.1200000000 , &
+ 10004.2700000000 , &
+ 9984.32000000000 , &
+ 9964.26000000000 , &
+ 9944.10000000000 , &
+ 9923.84000000000 , &
+ 9903.48000000000 , &
+ 5566.45000000000 , &
+ 5561.75000000000 /)
+
+ Mref_V%density_ref( 361 : 390 ) = (/ &
+ 5557.05000000000 , &
+ 5552.36000000000 , &
+ 5547.66000000000 , &
+ 5542.97000000000 , &
+ 5538.28000000000 , &
+ 5533.59000000000 , &
+ 5528.90000000000 , &
+ 5524.21000000000 , &
+ 5519.53000000000 , &
+ 5514.85000000000 , &
+ 5510.16000000000 , &
+ 5505.48000000000 , &
+ 5500.81000000000 , &
+ 5496.13000000000 , &
+ 5491.45000000000 , &
+ 5491.45000000000 , &
+ 5486.73000000000 , &
+ 5482.01000000000 , &
+ 5477.29000000000 , &
+ 5472.57000000000 , &
+ 5467.85000000000 , &
+ 5463.13000000000 , &
+ 5458.42000000000 , &
+ 5453.70000000000 , &
+ 5448.99000000000 , &
+ 5444.27000000000 , &
+ 5439.56000000000 , &
+ 5434.85000000000 , &
+ 5430.13000000000 , &
+ 5425.42000000000 /)
+
+ Mref_V%density_ref( 391 : 420 ) = (/ &
+ 5420.71000000000 , &
+ 5416.00000000000 , &
+ 5411.29000000000 , &
+ 5406.57000000000 , &
+ 5401.86000000000 , &
+ 5397.15000000000 , &
+ 5392.44000000000 , &
+ 5387.73000000000 , &
+ 5383.02000000000 , &
+ 5378.30000000000 , &
+ 5373.59000000000 , &
+ 5368.88000000000 , &
+ 5364.17000000000 , &
+ 5359.45000000000 , &
+ 5354.74000000000 , &
+ 5350.02000000000 , &
+ 5345.31000000000 , &
+ 5340.59000000000 , &
+ 5335.87000000000 , &
+ 5331.16000000000 , &
+ 5326.44000000000 , &
+ 5321.72000000000 , &
+ 5317.00000000000 , &
+ 5312.28000000000 , &
+ 5307.55000000000 , &
+ 5302.83000000000 , &
+ 5298.10000000000 , &
+ 5293.38000000000 , &
+ 5288.65000000000 , &
+ 5283.92000000000 /)
+
+ Mref_V%density_ref( 421 : 450 ) = (/ &
+ 5279.19000000000 , &
+ 5274.45000000000 , &
+ 5269.72000000000 , &
+ 5264.98000000000 , &
+ 5260.25000000000 , &
+ 5255.51000000000 , &
+ 5250.77000000000 , &
+ 5246.02000000000 , &
+ 5241.28000000000 , &
+ 5236.53000000000 , &
+ 5231.78000000000 , &
+ 5227.03000000000 , &
+ 5222.27000000000 , &
+ 5217.52000000000 , &
+ 5212.76000000000 , &
+ 5208.00000000000 , &
+ 5203.23000000000 , &
+ 5198.47000000000 , &
+ 5193.70000000000 , &
+ 5188.93000000000 , &
+ 5184.15000000000 , &
+ 5179.38000000000 , &
+ 5174.60000000000 , &
+ 5169.82000000000 , &
+ 5165.03000000000 , &
+ 5160.24000000000 , &
+ 5155.45000000000 , &
+ 5150.65000000000 , &
+ 5145.86000000000 , &
+ 5141.06000000000 /)
+
+ Mref_V%density_ref( 451 : 480 ) = (/ &
+ 5136.25000000000 , &
+ 5131.44000000000 , &
+ 5126.63000000000 , &
+ 5121.82000000000 , &
+ 5117.00000000000 , &
+ 5112.18000000000 , &
+ 5107.35000000000 , &
+ 5102.52000000000 , &
+ 5097.69000000000 , &
+ 5092.85000000000 , &
+ 5088.01000000000 , &
+ 5083.16000000000 , &
+ 5078.31000000000 , &
+ 5073.46000000000 , &
+ 5068.60000000000 , &
+ 5063.74000000000 , &
+ 5058.87000000000 , &
+ 5054.00000000000 , &
+ 5049.13000000000 , &
+ 5044.25000000000 , &
+ 5039.36000000000 , &
+ 5034.47000000000 , &
+ 5029.58000000000 , &
+ 5024.68000000000 , &
+ 5019.78000000000 , &
+ 5014.87000000000 , &
+ 5009.96000000000 , &
+ 5005.04000000000 , &
+ 5000.12000000000 , &
+ 4995.19000000000 /)
+
+ Mref_V%density_ref( 481 : 510 ) = (/ &
+ 4990.26000000000 , &
+ 4985.32000000000 , &
+ 4980.38000000000 , &
+ 4975.43000000000 , &
+ 4970.47000000000 , &
+ 4965.51000000000 , &
+ 4960.55000000000 , &
+ 4955.58000000000 , &
+ 4950.60000000000 , &
+ 4945.62000000000 , &
+ 4940.63000000000 , &
+ 4935.64000000000 , &
+ 4930.64000000000 , &
+ 4925.63000000000 , &
+ 4920.62000000000 , &
+ 4915.60000000000 , &
+ 4910.58000000000 , &
+ 4905.55000000000 , &
+ 4900.51000000000 , &
+ 4895.47000000000 , &
+ 4890.42000000000 , &
+ 4885.37000000000 , &
+ 4880.31000000000 , &
+ 4875.24000000000 , &
+ 4870.16000000000 , &
+ 4865.08000000000 , &
+ 4859.99000000000 , &
+ 4854.90000000000 , &
+ 4849.80000000000 , &
+ 4844.69000000000 /)
+
+ Mref_V%density_ref( 511 : 540 ) = (/ &
+ 4839.57000000000 , &
+ 4834.45000000000 , &
+ 4829.32000000000 , &
+ 4824.18000000000 , &
+ 4819.04000000000 , &
+ 4813.88000000000 , &
+ 4808.73000000000 , &
+ 4803.56000000000 , &
+ 4798.39000000000 , &
+ 4793.20000000000 , &
+ 4788.02000000000 , &
+ 4782.82000000000 , &
+ 4777.61000000000 , &
+ 4772.40000000000 , &
+ 4767.18000000000 , &
+ 4761.95000000000 , &
+ 4756.72000000000 , &
+ 4751.47000000000 , &
+ 4746.22000000000 , &
+ 4740.95000000000 , &
+ 4735.68000000000 , &
+ 4730.40000000000 , &
+ 4725.10000000000 , &
+ 4719.80000000000 , &
+ 4714.48000000000 , &
+ 4709.15000000000 , &
+ 4703.81000000000 , &
+ 4698.44000000000 , &
+ 4693.08000000000 , &
+ 4687.69000000000 /)
+
+ Mref_V%density_ref( 541 : 570 ) = (/ &
+ 4682.29000000000 , &
+ 4676.87000000000 , &
+ 4671.44000000000 , &
+ 4665.99000000000 , &
+ 4660.52000000000 , &
+ 4655.03000000000 , &
+ 4649.52000000000 , &
+ 4644.00000000000 , &
+ 4638.46000000000 , &
+ 4632.89000000000 , &
+ 4627.31000000000 , &
+ 4621.70000000000 , &
+ 4616.08000000000 , &
+ 4610.44000000000 , &
+ 4604.76000000000 , &
+ 4599.08000000000 , &
+ 4593.36000000000 , &
+ 4587.63000000000 , &
+ 4581.86000000000 , &
+ 4576.07000000000 , &
+ 4570.26000000000 , &
+ 4564.43000000000 , &
+ 4558.56000000000 , &
+ 4552.67000000000 , &
+ 4546.76000000000 , &
+ 4540.82000000000 , &
+ 4534.84000000000 , &
+ 4528.85000000000 , &
+ 4522.81000000000 , &
+ 4516.76000000000 /)
+
+ Mref_V%density_ref( 571 : 600 ) = (/ &
+ 4510.67000000000 , &
+ 4504.56000000000 , &
+ 4498.41000000000 , &
+ 4492.23000000000 , &
+ 4486.02000000000 , &
+ 4479.78000000000 , &
+ 4473.51000000000 , &
+ 4467.20000000000 , &
+ 4460.87000000000 , &
+ 4454.49000000000 , &
+ 4448.08000000000 , &
+ 4441.63000000000 , &
+ 4435.13000000000 , &
+ 4428.60000000000 , &
+ 4428.59000000000 , &
+ 4423.32000000000 , &
+ 4418.01000000000 , &
+ 4412.67000000000 , &
+ 4407.30000000000 , &
+ 4401.90000000000 , &
+ 4396.45000000000 , &
+ 4390.96000000000 , &
+ 4385.40000000000 , &
+ 4379.81000000000 , &
+ 4374.16000000000 , &
+ 4368.47000000000 , &
+ 4362.72000000000 , &
+ 4356.92000000000 , &
+ 4351.08000000000 , &
+ 4345.18000000000 /)
+
+ Mref_V%density_ref( 601 : 630 ) = (/ &
+ 4339.24000000000 , &
+ 4047.01000000000 , &
+ 4042.50000000000 , &
+ 4037.98000000000 , &
+ 4033.48000000000 , &
+ 4028.95000000000 , &
+ 4024.45000000000 , &
+ 4019.93000000000 , &
+ 4015.42000000000 , &
+ 4010.90000000000 , &
+ 4006.38000000000 , &
+ 4001.87000000000 , &
+ 3997.35000000000 , &
+ 3992.84000000000 , &
+ 3988.32000000000 , &
+ 3983.80000000000 , &
+ 3983.80000000000 , &
+ 3975.79000000000 , &
+ 3967.77000000000 , &
+ 3959.76000000000 , &
+ 3951.75000000000 , &
+ 3943.73000000000 , &
+ 3935.71000000000 , &
+ 3927.69000000000 , &
+ 3919.67000000000 , &
+ 3911.65000000000 , &
+ 3903.61000000000 , &
+ 3895.58000000000 , &
+ 3887.56000000000 , &
+ 3879.53000000000 /)
+
+ Mref_V%density_ref( 631 : 660 ) = (/ &
+ 3871.50000000000 , &
+ 3863.46000000000 , &
+ 3855.42000000000 , &
+ 3847.38000000000 , &
+ 3839.33000000000 , &
+ 3831.27000000000 , &
+ 3823.22000000000 , &
+ 3815.16000000000 , &
+ 3807.09000000000 , &
+ 3799.01000000000 , &
+ 3790.94000000000 , &
+ 3782.85000000000 , &
+ 3774.78000000000 , &
+ 3766.66000000000 , &
+ 3758.56000000000 , &
+ 3750.45000000000 , &
+ 3742.34000000000 , &
+ 3554.91000000000 , &
+ 3551.00000000000 , &
+ 3547.07000000000 , &
+ 3543.16000000000 , &
+ 3539.23000000000 , &
+ 3535.32000000000 , &
+ 3531.39000000000 , &
+ 3527.46000000000 , &
+ 3523.57000000000 , &
+ 3519.67000000000 , &
+ 3515.77000000000 , &
+ 3511.91000000000 , &
+ 3508.06000000000 /)
+
+ Mref_V%density_ref( 661 : 690 ) = (/ &
+ 3504.21000000000 , &
+ 3500.39000000000 , &
+ 3496.58000000000 , &
+ 3492.80000000000 , &
+ 3489.05000000000 , &
+ 3485.32000000000 , &
+ 3481.61000000000 , &
+ 3477.88000000000 , &
+ 3474.16000000000 , &
+ 3470.41000000000 , &
+ 3466.59000000000 , &
+ 3462.74000000000 , &
+ 3458.78000000000 , &
+ 3454.75000000000 , &
+ 3450.61000000000 , &
+ 3446.33000000000 , &
+ 3441.91000000000 , &
+ 3437.35000000000 , &
+ 3437.34000000000 , &
+ 3432.81000000000 , &
+ 3428.15000000000 , &
+ 3423.37000000000 , &
+ 3418.47000000000 , &
+ 3413.47000000000 , &
+ 3408.35000000000 , &
+ 3403.15000000000 , &
+ 3397.87000000000 , &
+ 3392.50000000000 , &
+ 3387.07000000000 , &
+ 3381.58000000000 /)
+
+ Mref_V%density_ref( 691 : 720 ) = (/ &
+ 3376.03000000000 , &
+ 3370.45000000000 , &
+ 3364.87000000000 , &
+ 3359.31000000000 , &
+ 3353.79000000000 , &
+ 3348.37000000000 , &
+ 3343.03000000000 , &
+ 3337.85000000000 , &
+ 3332.83000000000 , &
+ 3328.01000000000 , &
+ 3323.39000000000 , &
+ 3319.04000000000 , &
+ 3319.03000000000 , &
+ 3316.33000000000 , &
+ 3313.75000000000 , &
+ 3311.30000000000 , &
+ 3308.97000000000 , &
+ 3306.73000000000 , &
+ 3304.58000000000 , &
+ 3302.53000000000 , &
+ 3300.55000000000 , &
+ 3298.63000000000 , &
+ 3296.79000000000 , &
+ 3295.00000000000 , &
+ 3293.25000000000 , &
+ 3291.54000000000 , &
+ 3289.84000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 /)
+
+ Mref_V%density_ref( 721 : 750 ) = (/ &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 /)
+
+ Mref_V%vpv_ref( 1 : 30 ) = (/ &
+ 11262.2000000000 , &
+ 11262.2000000000 , &
+ 11262.1800000000 , &
+ 11262.1400000000 , &
+ 11262.0900000000 , &
+ 11262.0200000000 , &
+ 11261.9400000000 , &
+ 11261.8500000000 , &
+ 11261.7400000000 , &
+ 11261.6100000000 , &
+ 11261.4700000000 , &
+ 11261.3200000000 , &
+ 11261.1500000000 , &
+ 11260.9700000000 , &
+ 11260.7700000000 , &
+ 11260.5600000000 , &
+ 11260.3400000000 , &
+ 11260.0900000000 , &
+ 11259.8400000000 , &
+ 11259.5700000000 , &
+ 11259.2800000000 , &
+ 11258.9900000000 , &
+ 11258.6700000000 , &
+ 11258.3400000000 , &
+ 11258.0000000000 , &
+ 11257.6400000000 , &
+ 11257.2700000000 , &
+ 11256.8800000000 , &
+ 11256.4800000000 , &
+ 11256.0600000000 /)
+
+ Mref_V%vpv_ref( 31 : 60 ) = (/ &
+ 11255.6300000000 , &
+ 11255.1900000000 , &
+ 11254.7300000000 , &
+ 11254.2500000000 , &
+ 11253.7600000000 , &
+ 11253.2600000000 , &
+ 11252.7400000000 , &
+ 11252.2100000000 , &
+ 11251.6600000000 , &
+ 11251.1000000000 , &
+ 11250.5200000000 , &
+ 11249.9300000000 , &
+ 11249.3300000000 , &
+ 11248.7100000000 , &
+ 11248.0700000000 , &
+ 11247.4200000000 , &
+ 11246.7600000000 , &
+ 11246.0800000000 , &
+ 11245.3800000000 , &
+ 11244.6700000000 , &
+ 11243.9500000000 , &
+ 11243.2100000000 , &
+ 11242.4600000000 , &
+ 11241.7000000000 , &
+ 11240.9100000000 , &
+ 11240.1200000000 , &
+ 11239.3100000000 , &
+ 11238.4800000000 , &
+ 11237.6400000000 , &
+ 11236.7900000000 /)
+
+ Mref_V%vpv_ref( 61 : 90 ) = (/ &
+ 11235.9200000000 , &
+ 11235.0400000000 , &
+ 11234.1400000000 , &
+ 11233.2300000000 , &
+ 11232.3000000000 , &
+ 11231.3600000000 , &
+ 11230.4000000000 , &
+ 11229.4300000000 , &
+ 11228.4400000000 , &
+ 11227.4400000000 , &
+ 11226.4300000000 , &
+ 11225.4000000000 , &
+ 11224.3600000000 , &
+ 11223.3000000000 , &
+ 11222.2200000000 , &
+ 11221.1400000000 , &
+ 11220.0300000000 , &
+ 11218.9200000000 , &
+ 11217.7800000000 , &
+ 11216.6400000000 , &
+ 11215.4800000000 , &
+ 11214.3000000000 , &
+ 11213.1100000000 , &
+ 11211.9100000000 , &
+ 11210.6900000000 , &
+ 11209.4500000000 , &
+ 11208.2100000000 , &
+ 11206.9400000000 , &
+ 11205.6700000000 , &
+ 11204.3700000000 /)
+
+ Mref_V%vpv_ref( 91 : 120 ) = (/ &
+ 11203.0700000000 , &
+ 11201.7400000000 , &
+ 11200.4100000000 , &
+ 11199.0600000000 , &
+ 11197.6900000000 , &
+ 11196.3100000000 , &
+ 11194.9200000000 , &
+ 11193.5100000000 , &
+ 11192.0900000000 , &
+ 11190.6500000000 , &
+ 11189.1900000000 , &
+ 11187.7300000000 , &
+ 11186.2400000000 , &
+ 11184.7500000000 , &
+ 11183.2400000000 , &
+ 11181.7100000000 , &
+ 11180.1700000000 , &
+ 11178.6100000000 , &
+ 11177.0400000000 , &
+ 11175.4600000000 , &
+ 11173.8600000000 , &
+ 11172.2500000000 , &
+ 11170.6200000000 , &
+ 11168.9800000000 , &
+ 11167.3200000000 , &
+ 11165.6500000000 , &
+ 11163.9600000000 , &
+ 11162.2600000000 , &
+ 11160.5400000000 , &
+ 11158.8100000000 /)
+
+ Mref_V%vpv_ref( 121 : 150 ) = (/ &
+ 11157.0700000000 , &
+ 11155.3100000000 , &
+ 11153.5400000000 , &
+ 11151.7500000000 , &
+ 11149.9400000000 , &
+ 11148.1300000000 , &
+ 11146.2900000000 , &
+ 11144.4500000000 , &
+ 11142.5800000000 , &
+ 11140.7100000000 , &
+ 11138.8200000000 , &
+ 11136.9100000000 , &
+ 11134.9900000000 , &
+ 11133.0600000000 , &
+ 11131.1100000000 , &
+ 11129.1400000000 , &
+ 11127.1600000000 , &
+ 11125.1700000000 , &
+ 11123.1600000000 , &
+ 11121.1400000000 , &
+ 11119.1000000000 , &
+ 11117.0500000000 , &
+ 11114.9900000000 , &
+ 11112.9000000000 , &
+ 11110.8100000000 , &
+ 11108.7000000000 , &
+ 11106.5700000000 , &
+ 11104.4400000000 , &
+ 11102.2800000000 , &
+ 11100.1100000000 /)
+
+ Mref_V%vpv_ref( 151 : 180 ) = (/ &
+ 11097.9300000000 , &
+ 11095.7300000000 , &
+ 11093.5200000000 , &
+ 11091.2900000000 , &
+ 11089.0500000000 , &
+ 11086.8000000000 , &
+ 11084.5300000000 , &
+ 11082.2400000000 , &
+ 11079.9400000000 , &
+ 11077.6300000000 , &
+ 11075.3000000000 , &
+ 11072.9500000000 , &
+ 11070.5900000000 , &
+ 11068.2200000000 , &
+ 11065.8300000000 , &
+ 11063.4300000000 , &
+ 11061.0200000000 , &
+ 11058.5800000000 , &
+ 11056.1400000000 , &
+ 11053.6800000000 , &
+ 11051.2000000000 , &
+ 11048.7100000000 , &
+ 11046.2100000000 , &
+ 11043.6900000000 , &
+ 11041.1600000000 , &
+ 11038.6100000000 , &
+ 11036.0500000000 , &
+ 11033.4700000000 , &
+ 11030.8800000000 , &
+ 11028.2700000000 /)
+
+ Mref_V%vpv_ref( 181 : 210 ) = (/ &
+ 10355.6900000000 , &
+ 10348.2800000000 , &
+ 10340.8500000000 , &
+ 10333.3900000000 , &
+ 10325.9100000000 , &
+ 10318.4000000000 , &
+ 10310.8700000000 , &
+ 10303.3000000000 , &
+ 10295.7100000000 , &
+ 10288.0900000000 , &
+ 10280.4400000000 , &
+ 10272.7600000000 , &
+ 10265.0400000000 , &
+ 10257.3000000000 , &
+ 10249.5200000000 , &
+ 10241.7100000000 , &
+ 10233.8600000000 , &
+ 10225.9800000000 , &
+ 10218.0600000000 , &
+ 10210.1100000000 , &
+ 10202.1200000000 , &
+ 10194.1000000000 , &
+ 10186.0400000000 , &
+ 10177.9400000000 , &
+ 10169.7900000000 , &
+ 10161.6100000000 , &
+ 10153.3900000000 , &
+ 10145.1300000000 , &
+ 10136.8300000000 , &
+ 10128.4800000000 /)
+
+ Mref_V%vpv_ref( 211 : 240 ) = (/ &
+ 10120.0900000000 , &
+ 10111.6600000000 , &
+ 10103.1800000000 , &
+ 10094.6600000000 , &
+ 10086.0900000000 , &
+ 10077.4800000000 , &
+ 10068.8200000000 , &
+ 10060.1100000000 , &
+ 10051.3500000000 , &
+ 10042.5400000000 , &
+ 10033.6900000000 , &
+ 10024.7800000000 , &
+ 10015.8200000000 , &
+ 10006.8200000000 , &
+ 9997.75000000000 , &
+ 9988.64000000000 , &
+ 9979.47000000000 , &
+ 9970.25000000000 , &
+ 9960.97000000000 , &
+ 9951.64000000000 , &
+ 9942.25000000000 , &
+ 9932.81000000000 , &
+ 9923.31000000000 , &
+ 9913.75000000000 , &
+ 9904.13000000000 , &
+ 9894.45000000000 , &
+ 9884.71000000000 , &
+ 9874.91000000000 , &
+ 9865.05000000000 , &
+ 9855.13000000000 /)
+
+ Mref_V%vpv_ref( 241 : 270 ) = (/ &
+ 9845.14000000000 , &
+ 9835.09000000000 , &
+ 9824.98000000000 , &
+ 9814.80000000000 , &
+ 9804.56000000000 , &
+ 9794.25000000000 , &
+ 9783.87000000000 , &
+ 9773.43000000000 , &
+ 9762.92000000000 , &
+ 9752.34000000000 , &
+ 9741.69000000000 , &
+ 9730.97000000000 , &
+ 9720.18000000000 , &
+ 9709.32000000000 , &
+ 9698.39000000000 , &
+ 9687.38000000000 , &
+ 9676.31000000000 , &
+ 9665.15000000000 , &
+ 9653.93000000000 , &
+ 9642.63000000000 , &
+ 9631.25000000000 , &
+ 9619.80000000000 , &
+ 9608.27000000000 , &
+ 9596.66000000000 , &
+ 9584.97000000000 , &
+ 9573.20000000000 , &
+ 9561.36000000000 , &
+ 9549.43000000000 , &
+ 9537.43000000000 , &
+ 9525.34000000000 /)
+
+ Mref_V%vpv_ref( 271 : 300 ) = (/ &
+ 9513.17000000000 , &
+ 9500.91000000000 , &
+ 9488.57000000000 , &
+ 9476.15000000000 , &
+ 9463.64000000000 , &
+ 9451.05000000000 , &
+ 9438.37000000000 , &
+ 9425.61000000000 , &
+ 9412.75000000000 , &
+ 9399.81000000000 , &
+ 9386.78000000000 , &
+ 9373.66000000000 , &
+ 9360.45000000000 , &
+ 9347.15000000000 , &
+ 9333.76000000000 , &
+ 9320.27000000000 , &
+ 9306.70000000000 , &
+ 9293.03000000000 , &
+ 9279.26000000000 , &
+ 9265.40000000000 , &
+ 9251.45000000000 , &
+ 9237.40000000000 , &
+ 9223.25000000000 , &
+ 9209.00000000000 , &
+ 9194.66000000000 , &
+ 9180.22000000000 , &
+ 9165.68000000000 , &
+ 9151.03000000000 , &
+ 9136.29000000000 , &
+ 9121.45000000000 /)
+
+ Mref_V%vpv_ref( 301 : 330 ) = (/ &
+ 9106.50000000000 , &
+ 9091.46000000000 , &
+ 9076.30000000000 , &
+ 9061.05000000000 , &
+ 9045.69000000000 , &
+ 9030.23000000000 , &
+ 9014.65000000000 , &
+ 8998.98000000000 , &
+ 8983.19000000000 , &
+ 8967.30000000000 , &
+ 8951.30000000000 , &
+ 8935.19000000000 , &
+ 8918.97000000000 , &
+ 8902.64000000000 , &
+ 8886.20000000000 , &
+ 8869.64000000000 , &
+ 8852.98000000000 , &
+ 8836.20000000000 , &
+ 8819.31000000000 , &
+ 8802.30000000000 , &
+ 8785.18000000000 , &
+ 8767.94000000000 , &
+ 8750.59000000000 , &
+ 8733.12000000000 , &
+ 8715.53000000000 , &
+ 8697.82000000000 , &
+ 8680.00000000000 , &
+ 8662.05000000000 , &
+ 8643.99000000000 , &
+ 8625.80000000000 /)
+
+ Mref_V%vpv_ref( 331 : 360 ) = (/ &
+ 8607.49000000000 , &
+ 8589.06000000000 , &
+ 8570.51000000000 , &
+ 8551.83000000000 , &
+ 8533.03000000000 , &
+ 8514.10000000000 , &
+ 8495.05000000000 , &
+ 8475.87000000000 , &
+ 8456.57000000000 , &
+ 8437.14000000000 , &
+ 8417.58000000000 , &
+ 8397.89000000000 , &
+ 8378.07000000000 , &
+ 8358.12000000000 , &
+ 8338.04000000000 , &
+ 8317.83000000000 , &
+ 8297.49000000000 , &
+ 8277.01000000000 , &
+ 8256.41000000000 , &
+ 8235.66000000000 , &
+ 8214.79000000000 , &
+ 8193.77000000000 , &
+ 8172.62000000000 , &
+ 8151.34000000000 , &
+ 8129.92000000000 , &
+ 8108.36000000000 , &
+ 8086.66000000000 , &
+ 8064.82000000000 , &
+ 13716.6000000000 , &
+ 13714.2900000000 /)
+
+ Mref_V%vpv_ref( 361 : 390 ) = (/ &
+ 13712.0000000000 , &
+ 13709.7000000000 , &
+ 13707.4200000000 , &
+ 13705.1400000000 , &
+ 13702.8600000000 , &
+ 13700.5900000000 , &
+ 13698.3300000000 , &
+ 13696.0700000000 , &
+ 13693.8200000000 , &
+ 13691.5700000000 , &
+ 13689.3300000000 , &
+ 13687.0900000000 , &
+ 13684.8600000000 , &
+ 13682.6300000000 , &
+ 13680.4100000000 , &
+ 13680.4100000000 , &
+ 13668.9000000000 , &
+ 13657.4300000000 , &
+ 13645.9700000000 , &
+ 13634.5400000000 , &
+ 13623.1400000000 , &
+ 13611.7600000000 , &
+ 13600.4000000000 , &
+ 13589.0700000000 , &
+ 13577.7600000000 , &
+ 13566.4700000000 , &
+ 13555.2000000000 , &
+ 13543.9500000000 , &
+ 13532.7200000000 , &
+ 13521.5100000000 /)
+
+ Mref_V%vpv_ref( 391 : 420 ) = (/ &
+ 13510.3200000000 , &
+ 13499.1400000000 , &
+ 13487.9900000000 , &
+ 13476.8500000000 , &
+ 13465.7300000000 , &
+ 13454.6300000000 , &
+ 13443.5400000000 , &
+ 13432.4600000000 , &
+ 13421.4100000000 , &
+ 13410.3600000000 , &
+ 13399.3300000000 , &
+ 13388.3100000000 , &
+ 13377.3100000000 , &
+ 13366.3100000000 , &
+ 13355.3300000000 , &
+ 13344.3600000000 , &
+ 13333.4000000000 , &
+ 13322.4500000000 , &
+ 13311.5100000000 , &
+ 13300.5800000000 , &
+ 13289.6600000000 , &
+ 13278.7400000000 , &
+ 13267.8400000000 , &
+ 13256.9300000000 , &
+ 13246.0400000000 , &
+ 13235.1500000000 , &
+ 13224.2700000000 , &
+ 13213.3900000000 , &
+ 13202.5100000000 , &
+ 13191.6400000000 /)
+
+ Mref_V%vpv_ref( 421 : 450 ) = (/ &
+ 13180.7800000000 , &
+ 13169.9100000000 , &
+ 13159.0500000000 , &
+ 13148.1900000000 , &
+ 13137.3300000000 , &
+ 13126.4700000000 , &
+ 13115.6100000000 , &
+ 13104.7500000000 , &
+ 13093.8900000000 , &
+ 13083.0200000000 , &
+ 13072.1600000000 , &
+ 13061.2900000000 , &
+ 13050.4200000000 , &
+ 13039.5500000000 , &
+ 13028.6700000000 , &
+ 13017.7800000000 , &
+ 13006.9000000000 , &
+ 12996.0000000000 , &
+ 12985.1000000000 , &
+ 12974.1900000000 , &
+ 12963.2800000000 , &
+ 12952.3600000000 , &
+ 12941.4200000000 , &
+ 12930.4800000000 , &
+ 12919.5400000000 , &
+ 12908.5800000000 , &
+ 12897.6100000000 , &
+ 12886.6300000000 , &
+ 12875.6300000000 , &
+ 12864.6300000000 /)
+
+ Mref_V%vpv_ref( 451 : 480 ) = (/ &
+ 12853.6100000000 , &
+ 12842.5800000000 , &
+ 12831.5400000000 , &
+ 12820.4800000000 , &
+ 12809.4100000000 , &
+ 12798.3200000000 , &
+ 12787.2200000000 , &
+ 12776.1000000000 , &
+ 12764.9600000000 , &
+ 12753.8100000000 , &
+ 12742.6300000000 , &
+ 12731.4400000000 , &
+ 12720.2400000000 , &
+ 12709.0100000000 , &
+ 12697.7600000000 , &
+ 12686.4900000000 , &
+ 12675.2000000000 , &
+ 12663.8900000000 , &
+ 12652.5600000000 , &
+ 12641.2000000000 , &
+ 12629.8200000000 , &
+ 12618.4200000000 , &
+ 12606.9900000000 , &
+ 12595.5400000000 , &
+ 12584.0600000000 , &
+ 12572.5600000000 , &
+ 12561.0300000000 , &
+ 12549.4800000000 , &
+ 12537.8900000000 , &
+ 12526.2800000000 /)
+
+ Mref_V%vpv_ref( 481 : 510 ) = (/ &
+ 12514.6400000000 , &
+ 12502.9800000000 , &
+ 12491.2800000000 , &
+ 12479.5500000000 , &
+ 12467.7900000000 , &
+ 12456.0100000000 , &
+ 12444.1900000000 , &
+ 12432.3300000000 , &
+ 12420.4500000000 , &
+ 12408.5300000000 , &
+ 12396.5800000000 , &
+ 12384.6000000000 , &
+ 12372.5800000000 , &
+ 12360.5200000000 , &
+ 12348.4300000000 , &
+ 12336.3000000000 , &
+ 12324.1400000000 , &
+ 12311.9400000000 , &
+ 12299.7000000000 , &
+ 12287.4200000000 , &
+ 12275.1100000000 , &
+ 12262.7500000000 , &
+ 12250.3500000000 , &
+ 12237.9200000000 , &
+ 12225.4400000000 , &
+ 12212.9200000000 , &
+ 12200.3600000000 , &
+ 12187.7600000000 , &
+ 12175.1100000000 , &
+ 12162.4300000000 /)
+
+ Mref_V%vpv_ref( 511 : 540 ) = (/ &
+ 12149.6900000000 , &
+ 12136.9100000000 , &
+ 12124.0900000000 , &
+ 12111.2200000000 , &
+ 12098.3100000000 , &
+ 12085.3400000000 , &
+ 12072.3400000000 , &
+ 12059.2800000000 , &
+ 12046.1700000000 , &
+ 12033.0200000000 , &
+ 12019.8200000000 , &
+ 12006.5600000000 , &
+ 11993.2600000000 , &
+ 11979.9000000000 , &
+ 11966.5000000000 , &
+ 11953.0400000000 , &
+ 11939.5300000000 , &
+ 11925.9700000000 , &
+ 11912.3500000000 , &
+ 11898.6900000000 , &
+ 11884.9600000000 , &
+ 11871.1900000000 , &
+ 11857.3700000000 , &
+ 11843.4800000000 , &
+ 11829.5500000000 , &
+ 11815.5700000000 , &
+ 11801.5300000000 , &
+ 11787.4400000000 , &
+ 11773.3000000000 , &
+ 11759.1000000000 /)
+
+ Mref_V%vpv_ref( 541 : 570 ) = (/ &
+ 11744.8500000000 , &
+ 11730.5500000000 , &
+ 11716.1800000000 , &
+ 11701.7800000000 , &
+ 11687.3100000000 , &
+ 11672.8000000000 , &
+ 11658.2300000000 , &
+ 11643.6000000000 , &
+ 11628.9200000000 , &
+ 11614.1900000000 , &
+ 11599.4000000000 , &
+ 11584.5700000000 , &
+ 11569.6800000000 , &
+ 11554.7200000000 , &
+ 11539.7200000000 , &
+ 11524.6700000000 , &
+ 11509.5600000000 , &
+ 11494.3900000000 , &
+ 11479.1700000000 , &
+ 11463.8900000000 , &
+ 11448.5500000000 , &
+ 11433.1700000000 , &
+ 11417.7300000000 , &
+ 11402.2300000000 , &
+ 11386.6800000000 , &
+ 11371.0700000000 , &
+ 11355.4100000000 , &
+ 11339.6900000000 , &
+ 11323.9100000000 , &
+ 11308.0900000000 /)
+
+ Mref_V%vpv_ref( 571 : 600 ) = (/ &
+ 11292.2000000000 , &
+ 11276.2500000000 , &
+ 11260.2500000000 , &
+ 11244.1900000000 , &
+ 11228.0800000000 , &
+ 11211.9000000000 , &
+ 11195.6700000000 , &
+ 11179.3800000000 , &
+ 11163.0400000000 , &
+ 11146.6300000000 , &
+ 11130.1800000000 , &
+ 11113.6700000000 , &
+ 11097.1100000000 , &
+ 11080.5100000000 , &
+ 11080.5100000000 , &
+ 11063.0100000000 , &
+ 11045.2200000000 , &
+ 11026.8200000000 , &
+ 11008.4700000000 , &
+ 10989.0400000000 , &
+ 10969.6300000000 , &
+ 10948.7600000000 , &
+ 10928.0200000000 , &
+ 10907.4200000000 , &
+ 10886.9400000000 , &
+ 10866.6000000000 , &
+ 10846.4100000000 , &
+ 10826.3500000000 , &
+ 10806.4200000000 , &
+ 10786.6100000000 /)
+
+ Mref_V%vpv_ref( 601 : 630 ) = (/ &
+ 10766.9000000000 , &
+ 10278.8800000000 , &
+ 10261.8700000000 , &
+ 10244.8400000000 , &
+ 10227.8200000000 , &
+ 10210.8000000000 , &
+ 10193.7800000000 , &
+ 10176.7700000000 , &
+ 10159.7400000000 , &
+ 10142.7200000000 , &
+ 10125.7100000000 , &
+ 10108.7000000000 , &
+ 10091.6800000000 , &
+ 10074.6800000000 , &
+ 10057.6800000000 , &
+ 10040.6400000000 , &
+ 10040.6700000000 , &
+ 10010.5200000000 , &
+ 9980.51000000000 , &
+ 9950.64000000000 , &
+ 9920.91000000000 , &
+ 9891.35000000000 , &
+ 9861.96000000000 , &
+ 9832.79000000000 , &
+ 9803.79000000000 , &
+ 9774.98000000000 , &
+ 9746.41000000000 , &
+ 9718.08000000000 , &
+ 9689.96000000000 , &
+ 9662.10000000000 /)
+
+ Mref_V%vpv_ref( 631 : 660 ) = (/ &
+ 9634.47000000000 , &
+ 9607.11000000000 , &
+ 9579.97000000000 , &
+ 9553.08000000000 , &
+ 9526.38000000000 , &
+ 9499.78000000000 , &
+ 9473.25000000000 , &
+ 9446.74000000000 , &
+ 9420.19000000000 , &
+ 9393.55000000000 , &
+ 9366.75000000000 , &
+ 9339.76000000000 , &
+ 9312.50000000000 , &
+ 9284.96000000000 , &
+ 9257.04000000000 , &
+ 9228.73000000000 , &
+ 9199.94000000000 , &
+ 8940.94000000000 , &
+ 8930.61000000000 , &
+ 8920.22000000000 , &
+ 8909.68000000000 , &
+ 8898.47000000000 , &
+ 8886.28000000000 , &
+ 8873.03000000000 , &
+ 8858.58000000000 , &
+ 8842.82000000000 , &
+ 8825.64000000000 , &
+ 8806.94000000000 , &
+ 8786.67000000000 , &
+ 8764.85000000000 /)
+
+ Mref_V%vpv_ref( 661 : 690 ) = (/ &
+ 8741.49000000000 , &
+ 8716.63000000000 , &
+ 8690.30000000000 , &
+ 8662.50000000000 , &
+ 8633.28000000000 , &
+ 8602.66000000000 , &
+ 8570.81000000000 , &
+ 8538.06000000000 , &
+ 8504.66000000000 , &
+ 8470.92000000000 , &
+ 8437.13000000000 , &
+ 8403.52000000000 , &
+ 8370.42000000000 , &
+ 8338.11000000000 , &
+ 8306.25000000000 , &
+ 8275.42000000000 , &
+ 8241.77000000000 , &
+ 8207.37000000000 , &
+ 8207.01000000000 , &
+ 8174.32000000000 , &
+ 8141.99000000000 , &
+ 8110.40000000000 , &
+ 8079.71000000000 , &
+ 8050.15000000000 , &
+ 8021.89000000000 , &
+ 7995.08000000000 , &
+ 7969.97000000000 , &
+ 7946.70000000000 , &
+ 7925.45000000000 , &
+ 7906.44000000000 /)
+
+ Mref_V%vpv_ref( 691 : 720 ) = (/ &
+ 7889.80000000000 , &
+ 7875.56000000000 , &
+ 7863.64000000000 , &
+ 7853.87000000000 , &
+ 7846.17000000000 , &
+ 7840.38000000000 , &
+ 7836.39000000000 , &
+ 7834.11000000000 , &
+ 7833.38000000000 , &
+ 7834.11000000000 , &
+ 7836.11000000000 , &
+ 7839.12000000000 , &
+ 7839.37000000000 , &
+ 7841.82000000000 , &
+ 7844.77000000000 , &
+ 7848.07000000000 , &
+ 7851.72000000000 , &
+ 7855.75000000000 , &
+ 7860.14000000000 , &
+ 7864.89000000000 , &
+ 7870.01000000000 , &
+ 7875.49000000000 , &
+ 7881.33000000000 , &
+ 7887.54000000000 , &
+ 7894.13000000000 , &
+ 7901.10000000000 , &
+ 7908.24000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 /)
+
+ Mref_V%vpv_ref( 721 : 750 ) = (/ &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 /)
+
+ Mref_V%vsv_ref( 1 : 30 ) = (/ &
+ 3667.80000000000 , &
+ 3667.79000000000 , &
+ 3667.78000000000 , &
+ 3667.75000000000 , &
+ 3667.72000000000 , &
+ 3667.67000000000 , &
+ 3667.62000000000 , &
+ 3667.55000000000 , &
+ 3667.47000000000 , &
+ 3667.39000000000 , &
+ 3667.29000000000 , &
+ 3667.18000000000 , &
+ 3667.06000000000 , &
+ 3666.94000000000 , &
+ 3666.80000000000 , &
+ 3666.65000000000 , &
+ 3666.49000000000 , &
+ 3666.32000000000 , &
+ 3666.15000000000 , &
+ 3665.96000000000 , &
+ 3665.76000000000 , &
+ 3665.55000000000 , &
+ 3665.33000000000 , &
+ 3665.10000000000 , &
+ 3664.86000000000 , &
+ 3664.61000000000 , &
+ 3664.35000000000 , &
+ 3664.08000000000 , &
+ 3663.80000000000 , &
+ 3663.51000000000 /)
+
+ Mref_V%vsv_ref( 31 : 60 ) = (/ &
+ 3663.21000000000 , &
+ 3662.90000000000 , &
+ 3662.57000000000 , &
+ 3662.24000000000 , &
+ 3661.90000000000 , &
+ 3661.55000000000 , &
+ 3661.19000000000 , &
+ 3660.81000000000 , &
+ 3660.43000000000 , &
+ 3660.04000000000 , &
+ 3659.64000000000 , &
+ 3659.22000000000 , &
+ 3658.80000000000 , &
+ 3658.36000000000 , &
+ 3657.92000000000 , &
+ 3657.47000000000 , &
+ 3657.00000000000 , &
+ 3656.53000000000 , &
+ 3656.04000000000 , &
+ 3655.55000000000 , &
+ 3655.04000000000 , &
+ 3654.53000000000 , &
+ 3654.00000000000 , &
+ 3653.47000000000 , &
+ 3652.92000000000 , &
+ 3652.36000000000 , &
+ 3651.80000000000 , &
+ 3651.22000000000 , &
+ 3650.63000000000 , &
+ 3650.04000000000 /)
+
+ Mref_V%vsv_ref( 61 : 90 ) = (/ &
+ 3649.43000000000 , &
+ 3648.81000000000 , &
+ 3648.19000000000 , &
+ 3647.55000000000 , &
+ 3646.90000000000 , &
+ 3646.24000000000 , &
+ 3645.57000000000 , &
+ 3644.89000000000 , &
+ 3644.21000000000 , &
+ 3643.51000000000 , &
+ 3642.80000000000 , &
+ 3642.08000000000 , &
+ 3641.35000000000 , &
+ 3640.61000000000 , &
+ 3639.86000000000 , &
+ 3639.10000000000 , &
+ 3638.33000000000 , &
+ 3637.55000000000 , &
+ 3636.76000000000 , &
+ 3635.96000000000 , &
+ 3635.14000000000 , &
+ 3634.32000000000 , &
+ 3633.49000000000 , &
+ 3632.65000000000 , &
+ 3631.80000000000 , &
+ 3630.93000000000 , &
+ 3630.06000000000 , &
+ 3629.18000000000 , &
+ 3628.29000000000 , &
+ 3627.38000000000 /)
+
+ Mref_V%vsv_ref( 91 : 120 ) = (/ &
+ 3626.47000000000 , &
+ 3625.55000000000 , &
+ 3624.61000000000 , &
+ 3623.67000000000 , &
+ 3622.71000000000 , &
+ 3621.75000000000 , &
+ 3620.78000000000 , &
+ 3619.79000000000 , &
+ 3618.80000000000 , &
+ 3617.79000000000 , &
+ 3616.78000000000 , &
+ 3615.75000000000 , &
+ 3614.71000000000 , &
+ 3613.67000000000 , &
+ 3612.61000000000 , &
+ 3611.55000000000 , &
+ 3610.47000000000 , &
+ 3609.38000000000 , &
+ 3608.28000000000 , &
+ 3607.18000000000 , &
+ 3606.06000000000 , &
+ 3604.93000000000 , &
+ 3603.79000000000 , &
+ 3602.65000000000 , &
+ 3601.49000000000 , &
+ 3600.32000000000 , &
+ 3599.14000000000 , &
+ 3597.95000000000 , &
+ 3596.75000000000 , &
+ 3595.54000000000 /)
+
+ Mref_V%vsv_ref( 121 : 150 ) = (/ &
+ 3594.32000000000 , &
+ 3593.10000000000 , &
+ 3591.86000000000 , &
+ 3590.61000000000 , &
+ 3589.34000000000 , &
+ 3588.07000000000 , &
+ 3586.79000000000 , &
+ 3585.50000000000 , &
+ 3584.20000000000 , &
+ 3582.89000000000 , &
+ 3581.57000000000 , &
+ 3580.24000000000 , &
+ 3578.90000000000 , &
+ 3577.54000000000 , &
+ 3576.18000000000 , &
+ 3574.81000000000 , &
+ 3573.43000000000 , &
+ 3572.03000000000 , &
+ 3570.63000000000 , &
+ 3569.22000000000 , &
+ 3567.79000000000 , &
+ 3566.36000000000 , &
+ 3564.91000000000 , &
+ 3563.46000000000 , &
+ 3562.00000000000 , &
+ 3560.52000000000 , &
+ 3559.04000000000 , &
+ 3557.54000000000 , &
+ 3556.04000000000 , &
+ 3554.52000000000 /)
+
+ Mref_V%vsv_ref( 151 : 180 ) = (/ &
+ 3553.00000000000 , &
+ 3551.46000000000 , &
+ 3549.91000000000 , &
+ 3548.36000000000 , &
+ 3546.79000000000 , &
+ 3545.21000000000 , &
+ 3543.63000000000 , &
+ 3542.03000000000 , &
+ 3540.42000000000 , &
+ 3538.81000000000 , &
+ 3537.18000000000 , &
+ 3535.54000000000 , &
+ 3533.89000000000 , &
+ 3532.23000000000 , &
+ 3530.57000000000 , &
+ 3528.89000000000 , &
+ 3527.20000000000 , &
+ 3525.50000000000 , &
+ 3523.79000000000 , &
+ 3522.07000000000 , &
+ 3520.34000000000 , &
+ 3518.60000000000 , &
+ 3516.85000000000 , &
+ 3515.09000000000 , &
+ 3513.32000000000 , &
+ 3511.54000000000 , &
+ 3509.75000000000 , &
+ 3507.95000000000 , &
+ 3506.13000000000 , &
+ 3504.31000000000 /)
+
+ Mref_V%vsv_ref( 181 : 210 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsv_ref( 211 : 240 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsv_ref( 241 : 270 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsv_ref( 271 : 300 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsv_ref( 301 : 330 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsv_ref( 331 : 360 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 7264.66000000000 , &
+ 7264.75000000000 /)
+
+ Mref_V%vsv_ref( 361 : 390 ) = (/ &
+ 7264.85000000000 , &
+ 7264.94000000000 , &
+ 7265.03000000000 , &
+ 7265.12000000000 , &
+ 7265.21000000000 , &
+ 7265.29000000000 , &
+ 7265.38000000000 , &
+ 7265.46000000000 , &
+ 7265.54000000000 , &
+ 7265.62000000000 , &
+ 7265.69000000000 , &
+ 7265.76000000000 , &
+ 7265.84000000000 , &
+ 7265.91000000000 , &
+ 7265.97000000000 , &
+ 7265.97000000000 , &
+ 7261.63000000000 , &
+ 7257.29000000000 , &
+ 7252.97000000000 , &
+ 7248.64000000000 , &
+ 7244.33000000000 , &
+ 7240.01000000000 , &
+ 7235.71000000000 , &
+ 7231.41000000000 , &
+ 7227.12000000000 , &
+ 7222.83000000000 , &
+ 7218.55000000000 , &
+ 7214.27000000000 , &
+ 7210.00000000000 , &
+ 7205.73000000000 /)
+
+ Mref_V%vsv_ref( 391 : 420 ) = (/ &
+ 7201.47000000000 , &
+ 7197.21000000000 , &
+ 7192.95000000000 , &
+ 7188.70000000000 , &
+ 7184.45000000000 , &
+ 7180.21000000000 , &
+ 7175.97000000000 , &
+ 7171.73000000000 , &
+ 7167.50000000000 , &
+ 7163.27000000000 , &
+ 7159.04000000000 , &
+ 7154.81000000000 , &
+ 7150.59000000000 , &
+ 7146.37000000000 , &
+ 7142.15000000000 , &
+ 7137.93000000000 , &
+ 7133.71000000000 , &
+ 7129.50000000000 , &
+ 7125.29000000000 , &
+ 7121.07000000000 , &
+ 7116.86000000000 , &
+ 7112.65000000000 , &
+ 7108.44000000000 , &
+ 7104.23000000000 , &
+ 7100.02000000000 , &
+ 7095.81000000000 , &
+ 7091.60000000000 , &
+ 7087.39000000000 , &
+ 7083.18000000000 , &
+ 7078.96000000000 /)
+
+ Mref_V%vsv_ref( 421 : 450 ) = (/ &
+ 7074.75000000000 , &
+ 7070.54000000000 , &
+ 7066.32000000000 , &
+ 7062.10000000000 , &
+ 7057.88000000000 , &
+ 7053.66000000000 , &
+ 7049.44000000000 , &
+ 7045.22000000000 , &
+ 7040.99000000000 , &
+ 7036.76000000000 , &
+ 7032.52000000000 , &
+ 7028.29000000000 , &
+ 7024.05000000000 , &
+ 7019.81000000000 , &
+ 7015.56000000000 , &
+ 7011.31000000000 , &
+ 7007.06000000000 , &
+ 7002.80000000000 , &
+ 6998.54000000000 , &
+ 6994.27000000000 , &
+ 6990.00000000000 , &
+ 6985.72000000000 , &
+ 6981.44000000000 , &
+ 6977.15000000000 , &
+ 6972.86000000000 , &
+ 6968.57000000000 , &
+ 6964.26000000000 , &
+ 6959.95000000000 , &
+ 6955.64000000000 , &
+ 6951.32000000000 /)
+
+ Mref_V%vsv_ref( 451 : 480 ) = (/ &
+ 6946.99000000000 , &
+ 6942.66000000000 , &
+ 6938.31000000000 , &
+ 6933.97000000000 , &
+ 6929.61000000000 , &
+ 6925.25000000000 , &
+ 6920.88000000000 , &
+ 6916.50000000000 , &
+ 6912.11000000000 , &
+ 6907.72000000000 , &
+ 6903.32000000000 , &
+ 6898.91000000000 , &
+ 6894.49000000000 , &
+ 6890.06000000000 , &
+ 6885.62000000000 , &
+ 6881.17000000000 , &
+ 6876.72000000000 , &
+ 6872.25000000000 , &
+ 6867.78000000000 , &
+ 6863.29000000000 , &
+ 6858.80000000000 , &
+ 6854.29000000000 , &
+ 6849.78000000000 , &
+ 6845.25000000000 , &
+ 6840.71000000000 , &
+ 6836.16000000000 , &
+ 6831.60000000000 , &
+ 6827.03000000000 , &
+ 6822.45000000000 , &
+ 6817.85000000000 /)
+
+ Mref_V%vsv_ref( 481 : 510 ) = (/ &
+ 6813.25000000000 , &
+ 6808.63000000000 , &
+ 6804.00000000000 , &
+ 6799.35000000000 , &
+ 6794.70000000000 , &
+ 6790.03000000000 , &
+ 6785.34000000000 , &
+ 6780.65000000000 , &
+ 6775.94000000000 , &
+ 6771.22000000000 , &
+ 6766.48000000000 , &
+ 6761.73000000000 , &
+ 6756.97000000000 , &
+ 6752.19000000000 , &
+ 6747.40000000000 , &
+ 6742.59000000000 , &
+ 6737.76000000000 , &
+ 6732.93000000000 , &
+ 6728.07000000000 , &
+ 6723.21000000000 , &
+ 6718.32000000000 , &
+ 6713.42000000000 , &
+ 6708.51000000000 , &
+ 6703.57000000000 , &
+ 6698.62000000000 , &
+ 6693.66000000000 , &
+ 6688.68000000000 , &
+ 6683.68000000000 , &
+ 6678.66000000000 , &
+ 6673.63000000000 /)
+
+ Mref_V%vsv_ref( 511 : 540 ) = (/ &
+ 6668.58000000000 , &
+ 6663.51000000000 , &
+ 6658.43000000000 , &
+ 6653.32000000000 , &
+ 6648.20000000000 , &
+ 6643.06000000000 , &
+ 6637.90000000000 , &
+ 6632.73000000000 , &
+ 6627.53000000000 , &
+ 6622.31000000000 , &
+ 6617.08000000000 , &
+ 6611.82000000000 , &
+ 6606.55000000000 , &
+ 6601.26000000000 , &
+ 6595.94000000000 , &
+ 6590.61000000000 , &
+ 6584.91000000000 , &
+ 6579.51000000000 , &
+ 6574.11000000000 , &
+ 6568.67000000000 , &
+ 6563.22000000000 , &
+ 6557.74000000000 , &
+ 6552.24000000000 , &
+ 6546.73000000000 , &
+ 6541.19000000000 , &
+ 6535.63000000000 , &
+ 6530.05000000000 , &
+ 6524.44000000000 , &
+ 6518.82000000000 , &
+ 6513.17000000000 /)
+
+ Mref_V%vsv_ref( 541 : 570 ) = (/ &
+ 6507.50000000000 , &
+ 6501.80000000000 , &
+ 6496.09000000000 , &
+ 6490.35000000000 , &
+ 6484.59000000000 , &
+ 6478.80000000000 , &
+ 6472.99000000000 , &
+ 6467.16000000000 , &
+ 6461.30000000000 , &
+ 6455.42000000000 , &
+ 6449.51000000000 , &
+ 6443.58000000000 , &
+ 6437.63000000000 , &
+ 6431.65000000000 , &
+ 6425.65000000000 , &
+ 6419.61000000000 , &
+ 6413.56000000000 , &
+ 6407.48000000000 , &
+ 6401.37000000000 , &
+ 6395.25000000000 , &
+ 6389.09000000000 , &
+ 6382.91000000000 , &
+ 6376.70000000000 , &
+ 6370.46000000000 , &
+ 6364.20000000000 , &
+ 6357.91000000000 , &
+ 6351.59000000000 , &
+ 6345.25000000000 , &
+ 6338.88000000000 , &
+ 6332.49000000000 /)
+
+ Mref_V%vsv_ref( 571 : 600 ) = (/ &
+ 6326.05000000000 , &
+ 6319.60000000000 , &
+ 6313.13000000000 , &
+ 6306.62000000000 , &
+ 6300.08000000000 , &
+ 6293.52000000000 , &
+ 6286.92000000000 , &
+ 6280.29000000000 , &
+ 6273.64000000000 , &
+ 6266.96000000000 , &
+ 6260.25000000000 , &
+ 6253.51000000000 , &
+ 6246.75000000000 , &
+ 6239.95000000000 , &
+ 6239.95000000000 , &
+ 6219.68000000000 , &
+ 6200.29000000000 , &
+ 6181.16000000000 , &
+ 6162.04000000000 , &
+ 6143.01000000000 , &
+ 6123.98000000000 , &
+ 6103.71000000000 , &
+ 6083.53000000000 , &
+ 6063.45000000000 , &
+ 6043.44000000000 , &
+ 6023.52000000000 , &
+ 6003.73000000000 , &
+ 5984.03000000000 , &
+ 5964.38000000000 , &
+ 5944.81000000000 /)
+
+ Mref_V%vsv_ref( 601 : 630 ) = (/ &
+ 5925.27000000000 , &
+ 5550.32000000000 , &
+ 5541.20000000000 , &
+ 5532.08000000000 , &
+ 5522.96000000000 , &
+ 5513.83000000000 , &
+ 5504.71000000000 , &
+ 5495.59000000000 , &
+ 5486.47000000000 , &
+ 5477.35000000000 , &
+ 5468.22000000000 , &
+ 5459.10000000000 , &
+ 5449.97000000000 , &
+ 5440.84000000000 , &
+ 5431.71000000000 , &
+ 5422.57000000000 , &
+ 5422.59000000000 , &
+ 5406.39000000000 , &
+ 5390.30000000000 , &
+ 5374.34000000000 , &
+ 5358.52000000000 , &
+ 5342.83000000000 , &
+ 5327.31000000000 , &
+ 5311.92000000000 , &
+ 5296.73000000000 , &
+ 5281.71000000000 , &
+ 5266.86000000000 , &
+ 5252.21000000000 , &
+ 5237.78000000000 , &
+ 5223.55000000000 /)
+
+ Mref_V%vsv_ref( 631 : 660 ) = (/ &
+ 5209.54000000000 , &
+ 5195.72000000000 , &
+ 5182.10000000000 , &
+ 5168.69000000000 , &
+ 5155.42000000000 , &
+ 5142.22000000000 , &
+ 5129.05000000000 , &
+ 5115.84000000000 , &
+ 5102.55000000000 , &
+ 5089.14000000000 , &
+ 5075.50000000000 , &
+ 5061.63000000000 , &
+ 5047.46000000000 , &
+ 5032.93000000000 , &
+ 5018.03000000000 , &
+ 5002.66000000000 , &
+ 4986.77000000000 , &
+ 4802.15000000000 , &
+ 4798.23000000000 , &
+ 4794.28000000000 , &
+ 4790.38000000000 , &
+ 4785.95000000000 , &
+ 4780.83000000000 , &
+ 4775.01000000000 , &
+ 4768.45000000000 , &
+ 4761.12000000000 , &
+ 4752.97000000000 , &
+ 4744.01000000000 , &
+ 4734.25000000000 , &
+ 4723.77000000000 /)
+
+ Mref_V%vsv_ref( 661 : 690 ) = (/ &
+ 4712.70000000000 , &
+ 4701.12000000000 , &
+ 4689.11000000000 , &
+ 4676.77000000000 , &
+ 4664.20000000000 , &
+ 4651.49000000000 , &
+ 4638.69000000000 , &
+ 4625.88000000000 , &
+ 4613.07000000000 , &
+ 4600.31000000000 , &
+ 4587.67000000000 , &
+ 4575.18000000000 , &
+ 4562.88000000000 , &
+ 4550.85000000000 , &
+ 4539.08000000000 , &
+ 4527.67000000000 , &
+ 4516.65000000000 , &
+ 4506.09000000000 , &
+ 4506.00000000000 , &
+ 4496.29000000000 , &
+ 4487.00000000000 , &
+ 4478.17000000000 , &
+ 4469.83000000000 , &
+ 4462.00000000000 , &
+ 4454.69000000000 , &
+ 4447.94000000000 , &
+ 4441.76000000000 , &
+ 4436.18000000000 , &
+ 4431.20000000000 , &
+ 4426.83000000000 /)
+
+ Mref_V%vsv_ref( 691 : 720 ) = (/ &
+ 4423.12000000000 , &
+ 4420.09000000000 , &
+ 4417.81000000000 , &
+ 4416.30000000000 , &
+ 4415.67000000000 , &
+ 4415.93000000000 , &
+ 4417.15000000000 , &
+ 4419.42000000000 , &
+ 4422.78000000000 , &
+ 4427.25000000000 , &
+ 4432.88000000000 , &
+ 4439.57000000000 , &
+ 4439.74000000000 , &
+ 4444.71000000000 , &
+ 4450.28000000000 , &
+ 4456.35000000000 , &
+ 4462.89000000000 , &
+ 4469.94000000000 , &
+ 4477.40000000000 , &
+ 4485.33000000000 , &
+ 4493.69000000000 , &
+ 4502.48000000000 , &
+ 4511.66000000000 , &
+ 4521.24000000000 , &
+ 4531.23000000000 , &
+ 4541.57000000000 , &
+ 4552.08000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 /)
+
+ Mref_V%vsv_ref( 721 : 750 ) = (/ &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 /)
+
+ Mref_V%Qkappa_ref( 1 : 30 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 31 : 60 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 61 : 90 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 91 : 120 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 121 : 150 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 151 : 180 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 181 : 210 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 211 : 240 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 241 : 270 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 271 : 300 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 301 : 330 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 331 : 360 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 361 : 390 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 391 : 420 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 421 : 450 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 451 : 480 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 481 : 510 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 511 : 540 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 541 : 570 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 571 : 600 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 601 : 630 ) = (/ &
+ 57822.5000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 /)
+
+ Mref_V%Qkappa_ref( 631 : 660 ) = (/ &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 /)
+
+ Mref_V%Qkappa_ref( 661 : 690 ) = (/ &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 /)
+
+ Mref_V%Qkappa_ref( 691 : 720 ) = (/ &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 721 : 750 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qmu_ref( 1 : 30 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 31 : 60 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 61 : 90 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 91 : 120 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 121 : 150 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 151 : 180 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 181 : 210 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%Qmu_ref( 211 : 240 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%Qmu_ref( 241 : 270 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%Qmu_ref( 271 : 300 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%Qmu_ref( 301 : 330 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%Qmu_ref( 331 : 360 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 361 : 390 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 391 : 420 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 421 : 450 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 451 : 480 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 481 : 510 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 511 : 540 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 541 : 570 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 571 : 600 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 601 : 630 ) = (/ &
+ 355.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 /)
+
+ Mref_V%Qmu_ref( 631 : 660 ) = (/ &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 /)
+
+ Mref_V%Qmu_ref( 661 : 690 ) = (/ &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 /)
+
+ Mref_V%Qmu_ref( 691 : 720 ) = (/ &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 /)
+
+ Mref_V%Qmu_ref( 721 : 750 ) = (/ &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 /)
+
+ Mref_V%vph_ref( 1 : 30 ) = (/ &
+ 11262.2000000000 , &
+ 11262.2000000000 , &
+ 11262.1800000000 , &
+ 11262.1400000000 , &
+ 11262.0900000000 , &
+ 11262.0200000000 , &
+ 11261.9400000000 , &
+ 11261.8500000000 , &
+ 11261.7400000000 , &
+ 11261.6100000000 , &
+ 11261.4700000000 , &
+ 11261.3200000000 , &
+ 11261.1500000000 , &
+ 11260.9700000000 , &
+ 11260.7700000000 , &
+ 11260.5600000000 , &
+ 11260.3400000000 , &
+ 11260.0900000000 , &
+ 11259.8400000000 , &
+ 11259.5700000000 , &
+ 11259.2800000000 , &
+ 11258.9900000000 , &
+ 11258.6700000000 , &
+ 11258.3400000000 , &
+ 11258.0000000000 , &
+ 11257.6400000000 , &
+ 11257.2700000000 , &
+ 11256.8800000000 , &
+ 11256.4800000000 , &
+ 11256.0600000000 /)
+
+ Mref_V%vph_ref( 31 : 60 ) = (/ &
+ 11255.6300000000 , &
+ 11255.1900000000 , &
+ 11254.7300000000 , &
+ 11254.2500000000 , &
+ 11253.7600000000 , &
+ 11253.2600000000 , &
+ 11252.7400000000 , &
+ 11252.2100000000 , &
+ 11251.6600000000 , &
+ 11251.1000000000 , &
+ 11250.5200000000 , &
+ 11249.9300000000 , &
+ 11249.3300000000 , &
+ 11248.7100000000 , &
+ 11248.0700000000 , &
+ 11247.4200000000 , &
+ 11246.7600000000 , &
+ 11246.0800000000 , &
+ 11245.3800000000 , &
+ 11244.6700000000 , &
+ 11243.9500000000 , &
+ 11243.2100000000 , &
+ 11242.4600000000 , &
+ 11241.7000000000 , &
+ 11240.9100000000 , &
+ 11240.1200000000 , &
+ 11239.3100000000 , &
+ 11238.4800000000 , &
+ 11237.6400000000 , &
+ 11236.7900000000 /)
+
+ Mref_V%vph_ref( 61 : 90 ) = (/ &
+ 11235.9200000000 , &
+ 11235.0400000000 , &
+ 11234.1400000000 , &
+ 11233.2300000000 , &
+ 11232.3000000000 , &
+ 11231.3600000000 , &
+ 11230.4000000000 , &
+ 11229.4300000000 , &
+ 11228.4400000000 , &
+ 11227.4400000000 , &
+ 11226.4300000000 , &
+ 11225.4000000000 , &
+ 11224.3600000000 , &
+ 11223.3000000000 , &
+ 11222.2200000000 , &
+ 11221.1400000000 , &
+ 11220.0300000000 , &
+ 11218.9200000000 , &
+ 11217.7800000000 , &
+ 11216.6400000000 , &
+ 11215.4800000000 , &
+ 11214.3000000000 , &
+ 11213.1100000000 , &
+ 11211.9100000000 , &
+ 11210.6900000000 , &
+ 11209.4500000000 , &
+ 11208.2100000000 , &
+ 11206.9400000000 , &
+ 11205.6700000000 , &
+ 11204.3700000000 /)
+
+ Mref_V%vph_ref( 91 : 120 ) = (/ &
+ 11203.0700000000 , &
+ 11201.7400000000 , &
+ 11200.4100000000 , &
+ 11199.0600000000 , &
+ 11197.6900000000 , &
+ 11196.3100000000 , &
+ 11194.9200000000 , &
+ 11193.5100000000 , &
+ 11192.0900000000 , &
+ 11190.6500000000 , &
+ 11189.1900000000 , &
+ 11187.7300000000 , &
+ 11186.2400000000 , &
+ 11184.7500000000 , &
+ 11183.2400000000 , &
+ 11181.7100000000 , &
+ 11180.1700000000 , &
+ 11178.6100000000 , &
+ 11177.0400000000 , &
+ 11175.4600000000 , &
+ 11173.8600000000 , &
+ 11172.2500000000 , &
+ 11170.6200000000 , &
+ 11168.9800000000 , &
+ 11167.3200000000 , &
+ 11165.6500000000 , &
+ 11163.9600000000 , &
+ 11162.2600000000 , &
+ 11160.5400000000 , &
+ 11158.8100000000 /)
+
+ Mref_V%vph_ref( 121 : 150 ) = (/ &
+ 11157.0700000000 , &
+ 11155.3100000000 , &
+ 11153.5400000000 , &
+ 11151.7500000000 , &
+ 11149.9400000000 , &
+ 11148.1300000000 , &
+ 11146.2900000000 , &
+ 11144.4500000000 , &
+ 11142.5800000000 , &
+ 11140.7100000000 , &
+ 11138.8200000000 , &
+ 11136.9100000000 , &
+ 11134.9900000000 , &
+ 11133.0600000000 , &
+ 11131.1100000000 , &
+ 11129.1400000000 , &
+ 11127.1600000000 , &
+ 11125.1700000000 , &
+ 11123.1600000000 , &
+ 11121.1400000000 , &
+ 11119.1000000000 , &
+ 11117.0500000000 , &
+ 11114.9900000000 , &
+ 11112.9000000000 , &
+ 11110.8100000000 , &
+ 11108.7000000000 , &
+ 11106.5700000000 , &
+ 11104.4400000000 , &
+ 11102.2800000000 , &
+ 11100.1100000000 /)
+
+ Mref_V%vph_ref( 151 : 180 ) = (/ &
+ 11097.9300000000 , &
+ 11095.7300000000 , &
+ 11093.5200000000 , &
+ 11091.2900000000 , &
+ 11089.0500000000 , &
+ 11086.8000000000 , &
+ 11084.5300000000 , &
+ 11082.2400000000 , &
+ 11079.9400000000 , &
+ 11077.6300000000 , &
+ 11075.3000000000 , &
+ 11072.9500000000 , &
+ 11070.5900000000 , &
+ 11068.2200000000 , &
+ 11065.8300000000 , &
+ 11063.4300000000 , &
+ 11061.0200000000 , &
+ 11058.5800000000 , &
+ 11056.1400000000 , &
+ 11053.6800000000 , &
+ 11051.2000000000 , &
+ 11048.7100000000 , &
+ 11046.2100000000 , &
+ 11043.6900000000 , &
+ 11041.1600000000 , &
+ 11038.6100000000 , &
+ 11036.0500000000 , &
+ 11033.4700000000 , &
+ 11030.8800000000 , &
+ 11028.2700000000 /)
+
+ Mref_V%vph_ref( 181 : 210 ) = (/ &
+ 10355.6900000000 , &
+ 10348.2800000000 , &
+ 10340.8500000000 , &
+ 10333.3900000000 , &
+ 10325.9100000000 , &
+ 10318.4000000000 , &
+ 10310.8700000000 , &
+ 10303.3000000000 , &
+ 10295.7100000000 , &
+ 10288.0900000000 , &
+ 10280.4400000000 , &
+ 10272.7600000000 , &
+ 10265.0400000000 , &
+ 10257.3000000000 , &
+ 10249.5200000000 , &
+ 10241.7100000000 , &
+ 10233.8600000000 , &
+ 10225.9800000000 , &
+ 10218.0600000000 , &
+ 10210.1100000000 , &
+ 10202.1200000000 , &
+ 10194.1000000000 , &
+ 10186.0400000000 , &
+ 10177.9400000000 , &
+ 10169.7900000000 , &
+ 10161.6100000000 , &
+ 10153.3900000000 , &
+ 10145.1300000000 , &
+ 10136.8300000000 , &
+ 10128.4800000000 /)
+
+ Mref_V%vph_ref( 211 : 240 ) = (/ &
+ 10120.0900000000 , &
+ 10111.6600000000 , &
+ 10103.1800000000 , &
+ 10094.6600000000 , &
+ 10086.0900000000 , &
+ 10077.4800000000 , &
+ 10068.8200000000 , &
+ 10060.1100000000 , &
+ 10051.3500000000 , &
+ 10042.5400000000 , &
+ 10033.6900000000 , &
+ 10024.7800000000 , &
+ 10015.8200000000 , &
+ 10006.8200000000 , &
+ 9997.75000000000 , &
+ 9988.64000000000 , &
+ 9979.47000000000 , &
+ 9970.25000000000 , &
+ 9960.97000000000 , &
+ 9951.64000000000 , &
+ 9942.25000000000 , &
+ 9932.81000000000 , &
+ 9923.31000000000 , &
+ 9913.75000000000 , &
+ 9904.13000000000 , &
+ 9894.45000000000 , &
+ 9884.71000000000 , &
+ 9874.91000000000 , &
+ 9865.05000000000 , &
+ 9855.13000000000 /)
+
+ Mref_V%vph_ref( 241 : 270 ) = (/ &
+ 9845.14000000000 , &
+ 9835.09000000000 , &
+ 9824.98000000000 , &
+ 9814.80000000000 , &
+ 9804.56000000000 , &
+ 9794.25000000000 , &
+ 9783.87000000000 , &
+ 9773.43000000000 , &
+ 9762.92000000000 , &
+ 9752.34000000000 , &
+ 9741.69000000000 , &
+ 9730.97000000000 , &
+ 9720.18000000000 , &
+ 9709.32000000000 , &
+ 9698.39000000000 , &
+ 9687.38000000000 , &
+ 9676.31000000000 , &
+ 9665.15000000000 , &
+ 9653.93000000000 , &
+ 9642.63000000000 , &
+ 9631.25000000000 , &
+ 9619.80000000000 , &
+ 9608.27000000000 , &
+ 9596.66000000000 , &
+ 9584.97000000000 , &
+ 9573.20000000000 , &
+ 9561.36000000000 , &
+ 9549.43000000000 , &
+ 9537.43000000000 , &
+ 9525.34000000000 /)
+
+ Mref_V%vph_ref( 271 : 300 ) = (/ &
+ 9513.17000000000 , &
+ 9500.91000000000 , &
+ 9488.57000000000 , &
+ 9476.15000000000 , &
+ 9463.64000000000 , &
+ 9451.05000000000 , &
+ 9438.37000000000 , &
+ 9425.61000000000 , &
+ 9412.75000000000 , &
+ 9399.81000000000 , &
+ 9386.78000000000 , &
+ 9373.66000000000 , &
+ 9360.45000000000 , &
+ 9347.15000000000 , &
+ 9333.76000000000 , &
+ 9320.27000000000 , &
+ 9306.70000000000 , &
+ 9293.03000000000 , &
+ 9279.26000000000 , &
+ 9265.40000000000 , &
+ 9251.45000000000 , &
+ 9237.40000000000 , &
+ 9223.25000000000 , &
+ 9209.00000000000 , &
+ 9194.66000000000 , &
+ 9180.22000000000 , &
+ 9165.68000000000 , &
+ 9151.03000000000 , &
+ 9136.29000000000 , &
+ 9121.45000000000 /)
+
+ Mref_V%vph_ref( 301 : 330 ) = (/ &
+ 9106.50000000000 , &
+ 9091.46000000000 , &
+ 9076.30000000000 , &
+ 9061.05000000000 , &
+ 9045.69000000000 , &
+ 9030.23000000000 , &
+ 9014.65000000000 , &
+ 8998.98000000000 , &
+ 8983.19000000000 , &
+ 8967.30000000000 , &
+ 8951.30000000000 , &
+ 8935.19000000000 , &
+ 8918.97000000000 , &
+ 8902.64000000000 , &
+ 8886.20000000000 , &
+ 8869.64000000000 , &
+ 8852.98000000000 , &
+ 8836.20000000000 , &
+ 8819.31000000000 , &
+ 8802.30000000000 , &
+ 8785.18000000000 , &
+ 8767.94000000000 , &
+ 8750.59000000000 , &
+ 8733.12000000000 , &
+ 8715.53000000000 , &
+ 8697.82000000000 , &
+ 8680.00000000000 , &
+ 8662.05000000000 , &
+ 8643.99000000000 , &
+ 8625.80000000000 /)
+
+ Mref_V%vph_ref( 331 : 360 ) = (/ &
+ 8607.49000000000 , &
+ 8589.06000000000 , &
+ 8570.51000000000 , &
+ 8551.83000000000 , &
+ 8533.03000000000 , &
+ 8514.10000000000 , &
+ 8495.05000000000 , &
+ 8475.87000000000 , &
+ 8456.57000000000 , &
+ 8437.14000000000 , &
+ 8417.58000000000 , &
+ 8397.89000000000 , &
+ 8378.07000000000 , &
+ 8358.12000000000 , &
+ 8338.04000000000 , &
+ 8317.83000000000 , &
+ 8297.49000000000 , &
+ 8277.01000000000 , &
+ 8256.41000000000 , &
+ 8235.66000000000 , &
+ 8214.79000000000 , &
+ 8193.77000000000 , &
+ 8172.62000000000 , &
+ 8151.34000000000 , &
+ 8129.92000000000 , &
+ 8108.36000000000 , &
+ 8086.66000000000 , &
+ 8064.82000000000 , &
+ 13716.6000000000 , &
+ 13714.2900000000 /)
+
+ Mref_V%vph_ref( 361 : 390 ) = (/ &
+ 13712.0000000000 , &
+ 13709.7000000000 , &
+ 13707.4200000000 , &
+ 13705.1400000000 , &
+ 13702.8600000000 , &
+ 13700.5900000000 , &
+ 13698.3300000000 , &
+ 13696.0700000000 , &
+ 13693.8200000000 , &
+ 13691.5700000000 , &
+ 13689.3300000000 , &
+ 13687.0900000000 , &
+ 13684.8600000000 , &
+ 13682.6300000000 , &
+ 13680.4100000000 , &
+ 13680.4100000000 , &
+ 13668.9000000000 , &
+ 13657.4300000000 , &
+ 13645.9700000000 , &
+ 13634.5400000000 , &
+ 13623.1400000000 , &
+ 13611.7600000000 , &
+ 13600.4000000000 , &
+ 13589.0700000000 , &
+ 13577.7600000000 , &
+ 13566.4700000000 , &
+ 13555.2000000000 , &
+ 13543.9500000000 , &
+ 13532.7200000000 , &
+ 13521.5100000000 /)
+
+ Mref_V%vph_ref( 391 : 420 ) = (/ &
+ 13510.3200000000 , &
+ 13499.1400000000 , &
+ 13487.9900000000 , &
+ 13476.8500000000 , &
+ 13465.7300000000 , &
+ 13454.6300000000 , &
+ 13443.5400000000 , &
+ 13432.4600000000 , &
+ 13421.4100000000 , &
+ 13410.3600000000 , &
+ 13399.3300000000 , &
+ 13388.3100000000 , &
+ 13377.3100000000 , &
+ 13366.3100000000 , &
+ 13355.3300000000 , &
+ 13344.3600000000 , &
+ 13333.4000000000 , &
+ 13322.4500000000 , &
+ 13311.5100000000 , &
+ 13300.5800000000 , &
+ 13289.6600000000 , &
+ 13278.7400000000 , &
+ 13267.8400000000 , &
+ 13256.9300000000 , &
+ 13246.0400000000 , &
+ 13235.1500000000 , &
+ 13224.2700000000 , &
+ 13213.3900000000 , &
+ 13202.5100000000 , &
+ 13191.6400000000 /)
+
+ Mref_V%vph_ref( 421 : 450 ) = (/ &
+ 13180.7800000000 , &
+ 13169.9100000000 , &
+ 13159.0500000000 , &
+ 13148.1900000000 , &
+ 13137.3300000000 , &
+ 13126.4700000000 , &
+ 13115.6100000000 , &
+ 13104.7500000000 , &
+ 13093.8900000000 , &
+ 13083.0200000000 , &
+ 13072.1600000000 , &
+ 13061.2900000000 , &
+ 13050.4200000000 , &
+ 13039.5500000000 , &
+ 13028.6700000000 , &
+ 13017.7800000000 , &
+ 13006.9000000000 , &
+ 12996.0000000000 , &
+ 12985.1000000000 , &
+ 12974.1900000000 , &
+ 12963.2800000000 , &
+ 12952.3600000000 , &
+ 12941.4200000000 , &
+ 12930.4800000000 , &
+ 12919.5400000000 , &
+ 12908.5800000000 , &
+ 12897.6100000000 , &
+ 12886.6300000000 , &
+ 12875.6300000000 , &
+ 12864.6300000000 /)
+
+ Mref_V%vph_ref( 451 : 480 ) = (/ &
+ 12853.6100000000 , &
+ 12842.5800000000 , &
+ 12831.5400000000 , &
+ 12820.4800000000 , &
+ 12809.4100000000 , &
+ 12798.3200000000 , &
+ 12787.2200000000 , &
+ 12776.1000000000 , &
+ 12764.9600000000 , &
+ 12753.8100000000 , &
+ 12742.6300000000 , &
+ 12731.4400000000 , &
+ 12720.2400000000 , &
+ 12709.0100000000 , &
+ 12697.7600000000 , &
+ 12686.4900000000 , &
+ 12675.2000000000 , &
+ 12663.8900000000 , &
+ 12652.5600000000 , &
+ 12641.2000000000 , &
+ 12629.8200000000 , &
+ 12618.4200000000 , &
+ 12606.9900000000 , &
+ 12595.5400000000 , &
+ 12584.0600000000 , &
+ 12572.5600000000 , &
+ 12561.0300000000 , &
+ 12549.4800000000 , &
+ 12537.8900000000 , &
+ 12526.2800000000 /)
+
+ Mref_V%vph_ref( 481 : 510 ) = (/ &
+ 12514.6400000000 , &
+ 12502.9800000000 , &
+ 12491.2800000000 , &
+ 12479.5500000000 , &
+ 12467.7900000000 , &
+ 12456.0100000000 , &
+ 12444.1900000000 , &
+ 12432.3300000000 , &
+ 12420.4500000000 , &
+ 12408.5300000000 , &
+ 12396.5800000000 , &
+ 12384.6000000000 , &
+ 12372.5800000000 , &
+ 12360.5200000000 , &
+ 12348.4300000000 , &
+ 12336.3000000000 , &
+ 12324.1400000000 , &
+ 12311.9400000000 , &
+ 12299.7000000000 , &
+ 12287.4200000000 , &
+ 12275.1100000000 , &
+ 12262.7500000000 , &
+ 12250.3500000000 , &
+ 12237.9200000000 , &
+ 12225.4400000000 , &
+ 12212.9200000000 , &
+ 12200.3600000000 , &
+ 12187.7600000000 , &
+ 12175.1100000000 , &
+ 12162.4300000000 /)
+
+ Mref_V%vph_ref( 511 : 540 ) = (/ &
+ 12149.6900000000 , &
+ 12136.9100000000 , &
+ 12124.0900000000 , &
+ 12111.2200000000 , &
+ 12098.3100000000 , &
+ 12085.3400000000 , &
+ 12072.3400000000 , &
+ 12059.2800000000 , &
+ 12046.1700000000 , &
+ 12033.0200000000 , &
+ 12019.8200000000 , &
+ 12006.5600000000 , &
+ 11993.2600000000 , &
+ 11979.9000000000 , &
+ 11966.5000000000 , &
+ 11953.0400000000 , &
+ 11939.5300000000 , &
+ 11925.9700000000 , &
+ 11912.3500000000 , &
+ 11898.6900000000 , &
+ 11884.9600000000 , &
+ 11871.1900000000 , &
+ 11857.3700000000 , &
+ 11843.4800000000 , &
+ 11829.5500000000 , &
+ 11815.5700000000 , &
+ 11801.5300000000 , &
+ 11787.4400000000 , &
+ 11773.3000000000 , &
+ 11759.1000000000 /)
+
+ Mref_V%vph_ref( 541 : 570 ) = (/ &
+ 11744.8500000000 , &
+ 11730.5500000000 , &
+ 11716.1800000000 , &
+ 11701.7800000000 , &
+ 11687.3100000000 , &
+ 11672.8000000000 , &
+ 11658.2300000000 , &
+ 11643.6000000000 , &
+ 11628.9200000000 , &
+ 11614.1900000000 , &
+ 11599.4000000000 , &
+ 11584.5700000000 , &
+ 11569.6800000000 , &
+ 11554.7200000000 , &
+ 11539.7200000000 , &
+ 11524.6700000000 , &
+ 11509.5600000000 , &
+ 11494.3900000000 , &
+ 11479.1700000000 , &
+ 11463.8900000000 , &
+ 11448.5500000000 , &
+ 11433.1700000000 , &
+ 11417.7300000000 , &
+ 11402.2300000000 , &
+ 11386.6800000000 , &
+ 11371.0700000000 , &
+ 11355.4100000000 , &
+ 11339.6900000000 , &
+ 11323.9100000000 , &
+ 11308.0900000000 /)
+
+ Mref_V%vph_ref( 571 : 600 ) = (/ &
+ 11292.2000000000 , &
+ 11276.2500000000 , &
+ 11260.2500000000 , &
+ 11244.1900000000 , &
+ 11228.0800000000 , &
+ 11211.9000000000 , &
+ 11195.6700000000 , &
+ 11179.3800000000 , &
+ 11163.0400000000 , &
+ 11146.6300000000 , &
+ 11130.1800000000 , &
+ 11113.6700000000 , &
+ 11097.1100000000 , &
+ 11080.5100000000 , &
+ 11080.5100000000 , &
+ 11063.0100000000 , &
+ 11045.2200000000 , &
+ 11026.8200000000 , &
+ 11008.4700000000 , &
+ 10989.0400000000 , &
+ 10969.6300000000 , &
+ 10948.7600000000 , &
+ 10928.0200000000 , &
+ 10907.4200000000 , &
+ 10886.9400000000 , &
+ 10866.6000000000 , &
+ 10846.4100000000 , &
+ 10826.3500000000 , &
+ 10806.4200000000 , &
+ 10786.6100000000 /)
+
+ Mref_V%vph_ref( 601 : 630 ) = (/ &
+ 10766.9000000000 , &
+ 10278.8800000000 , &
+ 10261.8700000000 , &
+ 10244.8400000000 , &
+ 10227.8200000000 , &
+ 10210.8000000000 , &
+ 10193.7800000000 , &
+ 10176.7700000000 , &
+ 10159.7400000000 , &
+ 10142.7200000000 , &
+ 10125.7100000000 , &
+ 10108.7000000000 , &
+ 10091.6800000000 , &
+ 10074.6800000000 , &
+ 10057.6800000000 , &
+ 10040.6400000000 , &
+ 10040.6700000000 , &
+ 10010.5200000000 , &
+ 9980.51000000000 , &
+ 9950.64000000000 , &
+ 9920.91000000000 , &
+ 9891.35000000000 , &
+ 9861.96000000000 , &
+ 9832.79000000000 , &
+ 9803.79000000000 , &
+ 9774.98000000000 , &
+ 9746.41000000000 , &
+ 9718.08000000000 , &
+ 9689.96000000000 , &
+ 9662.10000000000 /)
+
+ Mref_V%vph_ref( 631 : 660 ) = (/ &
+ 9634.47000000000 , &
+ 9607.11000000000 , &
+ 9579.97000000000 , &
+ 9553.08000000000 , &
+ 9526.38000000000 , &
+ 9499.78000000000 , &
+ 9473.25000000000 , &
+ 9446.74000000000 , &
+ 9420.19000000000 , &
+ 9393.55000000000 , &
+ 9366.75000000000 , &
+ 9339.76000000000 , &
+ 9312.50000000000 , &
+ 9284.96000000000 , &
+ 9257.04000000000 , &
+ 9228.73000000000 , &
+ 9199.94000000000 , &
+ 8940.94000000000 , &
+ 8930.61000000000 , &
+ 8920.22000000000 , &
+ 8909.68000000000 , &
+ 8898.47000000000 , &
+ 8886.28000000000 , &
+ 8873.03000000000 , &
+ 8858.58000000000 , &
+ 8842.82000000000 , &
+ 8825.64000000000 , &
+ 8806.94000000000 , &
+ 8786.67000000000 , &
+ 8764.85000000000 /)
+
+ Mref_V%vph_ref( 661 : 690 ) = (/ &
+ 8741.49000000000 , &
+ 8716.63000000000 , &
+ 8690.30000000000 , &
+ 8662.50000000000 , &
+ 8633.28000000000 , &
+ 8602.66000000000 , &
+ 8570.81000000000 , &
+ 8538.06000000000 , &
+ 8504.66000000000 , &
+ 8470.92000000000 , &
+ 8437.13000000000 , &
+ 8403.52000000000 , &
+ 8370.42000000000 , &
+ 8338.11000000000 , &
+ 8307.42000000000 , &
+ 8278.36000000000 , &
+ 8255.33000000000 , &
+ 8236.90000000000 , &
+ 8236.81000000000 , &
+ 8222.27000000000 , &
+ 8210.47000000000 , &
+ 8201.14000000000 , &
+ 8193.99000000000 , &
+ 8188.67000000000 , &
+ 8184.92000000000 , &
+ 8182.39000000000 , &
+ 8180.79000000000 , &
+ 8179.83000000000 , &
+ 8179.17000000000 , &
+ 8178.54000000000 /)
+
+ Mref_V%vph_ref( 691 : 720 ) = (/ &
+ 8177.64000000000 , &
+ 8176.30000000000 , &
+ 8174.55000000000 , &
+ 8172.42000000000 , &
+ 8169.91000000000 , &
+ 8167.05000000000 , &
+ 8163.88000000000 , &
+ 8160.37000000000 , &
+ 8156.58000000000 , &
+ 8152.57000000000 , &
+ 8148.41000000000 , &
+ 8144.20000000000 , &
+ 8144.32000000000 , &
+ 8141.60000000000 , &
+ 8139.01000000000 , &
+ 8136.50000000000 , &
+ 8134.11000000000 , &
+ 8131.82000000000 , &
+ 8129.66000000000 , &
+ 8127.60000000000 , &
+ 8125.65000000000 , &
+ 8123.87000000000 , &
+ 8122.23000000000 , &
+ 8120.74000000000 , &
+ 8119.38000000000 , &
+ 8118.22000000000 , &
+ 8117.13000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 /)
+
+ Mref_V%vph_ref( 721 : 750 ) = (/ &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 /)
+
+ Mref_V%vsh_ref( 1 : 30 ) = (/ &
+ 3667.80000000000 , &
+ 3667.79000000000 , &
+ 3667.78000000000 , &
+ 3667.75000000000 , &
+ 3667.72000000000 , &
+ 3667.67000000000 , &
+ 3667.62000000000 , &
+ 3667.55000000000 , &
+ 3667.47000000000 , &
+ 3667.39000000000 , &
+ 3667.29000000000 , &
+ 3667.18000000000 , &
+ 3667.06000000000 , &
+ 3666.94000000000 , &
+ 3666.80000000000 , &
+ 3666.65000000000 , &
+ 3666.49000000000 , &
+ 3666.32000000000 , &
+ 3666.15000000000 , &
+ 3665.96000000000 , &
+ 3665.76000000000 , &
+ 3665.55000000000 , &
+ 3665.33000000000 , &
+ 3665.10000000000 , &
+ 3664.86000000000 , &
+ 3664.61000000000 , &
+ 3664.35000000000 , &
+ 3664.08000000000 , &
+ 3663.80000000000 , &
+ 3663.51000000000 /)
+
+ Mref_V%vsh_ref( 31 : 60 ) = (/ &
+ 3663.21000000000 , &
+ 3662.90000000000 , &
+ 3662.57000000000 , &
+ 3662.24000000000 , &
+ 3661.90000000000 , &
+ 3661.55000000000 , &
+ 3661.19000000000 , &
+ 3660.81000000000 , &
+ 3660.43000000000 , &
+ 3660.04000000000 , &
+ 3659.64000000000 , &
+ 3659.22000000000 , &
+ 3658.80000000000 , &
+ 3658.36000000000 , &
+ 3657.92000000000 , &
+ 3657.47000000000 , &
+ 3657.00000000000 , &
+ 3656.53000000000 , &
+ 3656.04000000000 , &
+ 3655.55000000000 , &
+ 3655.04000000000 , &
+ 3654.53000000000 , &
+ 3654.00000000000 , &
+ 3653.47000000000 , &
+ 3652.92000000000 , &
+ 3652.36000000000 , &
+ 3651.80000000000 , &
+ 3651.22000000000 , &
+ 3650.63000000000 , &
+ 3650.04000000000 /)
+
+ Mref_V%vsh_ref( 61 : 90 ) = (/ &
+ 3649.43000000000 , &
+ 3648.81000000000 , &
+ 3648.19000000000 , &
+ 3647.55000000000 , &
+ 3646.90000000000 , &
+ 3646.24000000000 , &
+ 3645.57000000000 , &
+ 3644.89000000000 , &
+ 3644.21000000000 , &
+ 3643.51000000000 , &
+ 3642.80000000000 , &
+ 3642.08000000000 , &
+ 3641.35000000000 , &
+ 3640.61000000000 , &
+ 3639.86000000000 , &
+ 3639.10000000000 , &
+ 3638.33000000000 , &
+ 3637.55000000000 , &
+ 3636.76000000000 , &
+ 3635.96000000000 , &
+ 3635.14000000000 , &
+ 3634.32000000000 , &
+ 3633.49000000000 , &
+ 3632.65000000000 , &
+ 3631.80000000000 , &
+ 3630.93000000000 , &
+ 3630.06000000000 , &
+ 3629.18000000000 , &
+ 3628.29000000000 , &
+ 3627.38000000000 /)
+
+ Mref_V%vsh_ref( 91 : 120 ) = (/ &
+ 3626.47000000000 , &
+ 3625.55000000000 , &
+ 3624.61000000000 , &
+ 3623.67000000000 , &
+ 3622.71000000000 , &
+ 3621.75000000000 , &
+ 3620.78000000000 , &
+ 3619.79000000000 , &
+ 3618.80000000000 , &
+ 3617.79000000000 , &
+ 3616.78000000000 , &
+ 3615.75000000000 , &
+ 3614.71000000000 , &
+ 3613.67000000000 , &
+ 3612.61000000000 , &
+ 3611.55000000000 , &
+ 3610.47000000000 , &
+ 3609.38000000000 , &
+ 3608.28000000000 , &
+ 3607.18000000000 , &
+ 3606.06000000000 , &
+ 3604.93000000000 , &
+ 3603.79000000000 , &
+ 3602.65000000000 , &
+ 3601.49000000000 , &
+ 3600.32000000000 , &
+ 3599.14000000000 , &
+ 3597.95000000000 , &
+ 3596.75000000000 , &
+ 3595.54000000000 /)
+
+ Mref_V%vsh_ref( 121 : 150 ) = (/ &
+ 3594.32000000000 , &
+ 3593.10000000000 , &
+ 3591.86000000000 , &
+ 3590.61000000000 , &
+ 3589.34000000000 , &
+ 3588.07000000000 , &
+ 3586.79000000000 , &
+ 3585.50000000000 , &
+ 3584.20000000000 , &
+ 3582.89000000000 , &
+ 3581.57000000000 , &
+ 3580.24000000000 , &
+ 3578.90000000000 , &
+ 3577.54000000000 , &
+ 3576.18000000000 , &
+ 3574.81000000000 , &
+ 3573.43000000000 , &
+ 3572.03000000000 , &
+ 3570.63000000000 , &
+ 3569.22000000000 , &
+ 3567.79000000000 , &
+ 3566.36000000000 , &
+ 3564.91000000000 , &
+ 3563.46000000000 , &
+ 3562.00000000000 , &
+ 3560.52000000000 , &
+ 3559.04000000000 , &
+ 3557.54000000000 , &
+ 3556.04000000000 , &
+ 3554.52000000000 /)
+
+ Mref_V%vsh_ref( 151 : 180 ) = (/ &
+ 3553.00000000000 , &
+ 3551.46000000000 , &
+ 3549.91000000000 , &
+ 3548.36000000000 , &
+ 3546.79000000000 , &
+ 3545.21000000000 , &
+ 3543.63000000000 , &
+ 3542.03000000000 , &
+ 3540.42000000000 , &
+ 3538.81000000000 , &
+ 3537.18000000000 , &
+ 3535.54000000000 , &
+ 3533.89000000000 , &
+ 3532.23000000000 , &
+ 3530.57000000000 , &
+ 3528.89000000000 , &
+ 3527.20000000000 , &
+ 3525.50000000000 , &
+ 3523.79000000000 , &
+ 3522.07000000000 , &
+ 3520.34000000000 , &
+ 3518.60000000000 , &
+ 3516.85000000000 , &
+ 3515.09000000000 , &
+ 3513.32000000000 , &
+ 3511.54000000000 , &
+ 3509.75000000000 , &
+ 3507.95000000000 , &
+ 3506.13000000000 , &
+ 3504.31000000000 /)
+
+ Mref_V%vsh_ref( 181 : 210 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsh_ref( 211 : 240 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsh_ref( 241 : 270 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsh_ref( 271 : 300 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsh_ref( 301 : 330 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsh_ref( 331 : 360 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 7264.66000000000 , &
+ 7264.75000000000 /)
+
+ Mref_V%vsh_ref( 361 : 390 ) = (/ &
+ 7264.85000000000 , &
+ 7264.94000000000 , &
+ 7265.03000000000 , &
+ 7265.12000000000 , &
+ 7265.21000000000 , &
+ 7265.29000000000 , &
+ 7265.38000000000 , &
+ 7265.46000000000 , &
+ 7265.54000000000 , &
+ 7265.62000000000 , &
+ 7265.69000000000 , &
+ 7265.76000000000 , &
+ 7265.84000000000 , &
+ 7265.91000000000 , &
+ 7265.97000000000 , &
+ 7265.97000000000 , &
+ 7261.63000000000 , &
+ 7257.29000000000 , &
+ 7252.97000000000 , &
+ 7248.64000000000 , &
+ 7244.33000000000 , &
+ 7240.01000000000 , &
+ 7235.71000000000 , &
+ 7231.41000000000 , &
+ 7227.12000000000 , &
+ 7222.83000000000 , &
+ 7218.55000000000 , &
+ 7214.27000000000 , &
+ 7210.00000000000 , &
+ 7205.73000000000 /)
+
+ Mref_V%vsh_ref( 391 : 420 ) = (/ &
+ 7201.47000000000 , &
+ 7197.21000000000 , &
+ 7192.95000000000 , &
+ 7188.70000000000 , &
+ 7184.45000000000 , &
+ 7180.21000000000 , &
+ 7175.97000000000 , &
+ 7171.73000000000 , &
+ 7167.50000000000 , &
+ 7163.27000000000 , &
+ 7159.04000000000 , &
+ 7154.81000000000 , &
+ 7150.59000000000 , &
+ 7146.37000000000 , &
+ 7142.15000000000 , &
+ 7137.93000000000 , &
+ 7133.71000000000 , &
+ 7129.50000000000 , &
+ 7125.29000000000 , &
+ 7121.07000000000 , &
+ 7116.86000000000 , &
+ 7112.65000000000 , &
+ 7108.44000000000 , &
+ 7104.23000000000 , &
+ 7100.02000000000 , &
+ 7095.81000000000 , &
+ 7091.60000000000 , &
+ 7087.39000000000 , &
+ 7083.18000000000 , &
+ 7078.96000000000 /)
+
+ Mref_V%vsh_ref( 421 : 450 ) = (/ &
+ 7074.75000000000 , &
+ 7070.54000000000 , &
+ 7066.32000000000 , &
+ 7062.10000000000 , &
+ 7057.88000000000 , &
+ 7053.66000000000 , &
+ 7049.44000000000 , &
+ 7045.22000000000 , &
+ 7040.99000000000 , &
+ 7036.76000000000 , &
+ 7032.52000000000 , &
+ 7028.29000000000 , &
+ 7024.05000000000 , &
+ 7019.81000000000 , &
+ 7015.56000000000 , &
+ 7011.31000000000 , &
+ 7007.06000000000 , &
+ 7002.80000000000 , &
+ 6998.54000000000 , &
+ 6994.27000000000 , &
+ 6990.00000000000 , &
+ 6985.72000000000 , &
+ 6981.44000000000 , &
+ 6977.15000000000 , &
+ 6972.86000000000 , &
+ 6968.57000000000 , &
+ 6964.26000000000 , &
+ 6959.95000000000 , &
+ 6955.64000000000 , &
+ 6951.32000000000 /)
+
+ Mref_V%vsh_ref( 451 : 480 ) = (/ &
+ 6946.99000000000 , &
+ 6942.66000000000 , &
+ 6938.31000000000 , &
+ 6933.97000000000 , &
+ 6929.61000000000 , &
+ 6925.25000000000 , &
+ 6920.88000000000 , &
+ 6916.50000000000 , &
+ 6912.11000000000 , &
+ 6907.72000000000 , &
+ 6903.32000000000 , &
+ 6898.91000000000 , &
+ 6894.49000000000 , &
+ 6890.06000000000 , &
+ 6885.62000000000 , &
+ 6881.17000000000 , &
+ 6876.72000000000 , &
+ 6872.25000000000 , &
+ 6867.78000000000 , &
+ 6863.29000000000 , &
+ 6858.80000000000 , &
+ 6854.29000000000 , &
+ 6849.78000000000 , &
+ 6845.25000000000 , &
+ 6840.71000000000 , &
+ 6836.16000000000 , &
+ 6831.60000000000 , &
+ 6827.03000000000 , &
+ 6822.45000000000 , &
+ 6817.85000000000 /)
+
+ Mref_V%vsh_ref( 481 : 510 ) = (/ &
+ 6813.25000000000 , &
+ 6808.63000000000 , &
+ 6804.00000000000 , &
+ 6799.35000000000 , &
+ 6794.70000000000 , &
+ 6790.03000000000 , &
+ 6785.34000000000 , &
+ 6780.65000000000 , &
+ 6775.94000000000 , &
+ 6771.22000000000 , &
+ 6766.48000000000 , &
+ 6761.73000000000 , &
+ 6756.97000000000 , &
+ 6752.19000000000 , &
+ 6747.40000000000 , &
+ 6742.59000000000 , &
+ 6737.76000000000 , &
+ 6732.93000000000 , &
+ 6728.07000000000 , &
+ 6723.21000000000 , &
+ 6718.32000000000 , &
+ 6713.42000000000 , &
+ 6708.51000000000 , &
+ 6703.57000000000 , &
+ 6698.62000000000 , &
+ 6693.66000000000 , &
+ 6688.68000000000 , &
+ 6683.68000000000 , &
+ 6678.66000000000 , &
+ 6673.63000000000 /)
+
+ Mref_V%vsh_ref( 511 : 540 ) = (/ &
+ 6668.58000000000 , &
+ 6663.51000000000 , &
+ 6658.43000000000 , &
+ 6653.32000000000 , &
+ 6648.20000000000 , &
+ 6643.06000000000 , &
+ 6637.90000000000 , &
+ 6632.73000000000 , &
+ 6627.53000000000 , &
+ 6622.31000000000 , &
+ 6617.08000000000 , &
+ 6611.82000000000 , &
+ 6606.55000000000 , &
+ 6601.26000000000 , &
+ 6595.94000000000 , &
+ 6590.61000000000 , &
+ 6584.91000000000 , &
+ 6579.51000000000 , &
+ 6574.11000000000 , &
+ 6568.67000000000 , &
+ 6563.22000000000 , &
+ 6557.74000000000 , &
+ 6552.24000000000 , &
+ 6546.73000000000 , &
+ 6541.19000000000 , &
+ 6535.63000000000 , &
+ 6530.05000000000 , &
+ 6524.44000000000 , &
+ 6518.82000000000 , &
+ 6513.17000000000 /)
+
+ Mref_V%vsh_ref( 541 : 570 ) = (/ &
+ 6507.50000000000 , &
+ 6501.80000000000 , &
+ 6496.09000000000 , &
+ 6490.35000000000 , &
+ 6484.59000000000 , &
+ 6478.80000000000 , &
+ 6472.99000000000 , &
+ 6467.16000000000 , &
+ 6461.30000000000 , &
+ 6455.42000000000 , &
+ 6449.51000000000 , &
+ 6443.58000000000 , &
+ 6437.63000000000 , &
+ 6431.65000000000 , &
+ 6425.65000000000 , &
+ 6419.61000000000 , &
+ 6413.56000000000 , &
+ 6407.48000000000 , &
+ 6401.37000000000 , &
+ 6395.25000000000 , &
+ 6389.09000000000 , &
+ 6382.91000000000 , &
+ 6376.70000000000 , &
+ 6370.46000000000 , &
+ 6364.20000000000 , &
+ 6357.91000000000 , &
+ 6351.59000000000 , &
+ 6345.25000000000 , &
+ 6338.88000000000 , &
+ 6332.49000000000 /)
+
+ Mref_V%vsh_ref( 571 : 600 ) = (/ &
+ 6326.05000000000 , &
+ 6319.60000000000 , &
+ 6313.13000000000 , &
+ 6306.62000000000 , &
+ 6300.08000000000 , &
+ 6293.52000000000 , &
+ 6286.92000000000 , &
+ 6280.29000000000 , &
+ 6273.64000000000 , &
+ 6266.96000000000 , &
+ 6260.25000000000 , &
+ 6253.51000000000 , &
+ 6246.75000000000 , &
+ 6239.95000000000 , &
+ 6239.95000000000 , &
+ 6219.68000000000 , &
+ 6200.29000000000 , &
+ 6181.16000000000 , &
+ 6162.04000000000 , &
+ 6143.01000000000 , &
+ 6123.98000000000 , &
+ 6103.71000000000 , &
+ 6083.53000000000 , &
+ 6063.45000000000 , &
+ 6043.44000000000 , &
+ 6023.52000000000 , &
+ 6003.73000000000 , &
+ 5984.03000000000 , &
+ 5964.38000000000 , &
+ 5944.81000000000 /)
+
+ Mref_V%vsh_ref( 601 : 630 ) = (/ &
+ 5925.27000000000 , &
+ 5550.32000000000 , &
+ 5541.20000000000 , &
+ 5532.08000000000 , &
+ 5522.96000000000 , &
+ 5513.83000000000 , &
+ 5504.71000000000 , &
+ 5495.59000000000 , &
+ 5486.47000000000 , &
+ 5477.35000000000 , &
+ 5468.22000000000 , &
+ 5459.10000000000 , &
+ 5449.97000000000 , &
+ 5440.84000000000 , &
+ 5431.71000000000 , &
+ 5422.57000000000 , &
+ 5422.59000000000 , &
+ 5406.39000000000 , &
+ 5390.30000000000 , &
+ 5374.34000000000 , &
+ 5358.52000000000 , &
+ 5342.83000000000 , &
+ 5327.31000000000 , &
+ 5311.92000000000 , &
+ 5296.73000000000 , &
+ 5281.71000000000 , &
+ 5266.86000000000 , &
+ 5252.21000000000 , &
+ 5237.78000000000 , &
+ 5223.55000000000 /)
+
+ Mref_V%vsh_ref( 631 : 660 ) = (/ &
+ 5209.54000000000 , &
+ 5195.72000000000 , &
+ 5182.10000000000 , &
+ 5168.69000000000 , &
+ 5155.42000000000 , &
+ 5142.22000000000 , &
+ 5129.05000000000 , &
+ 5115.84000000000 , &
+ 5102.55000000000 , &
+ 5089.14000000000 , &
+ 5075.50000000000 , &
+ 5061.63000000000 , &
+ 5047.46000000000 , &
+ 5032.93000000000 , &
+ 5018.03000000000 , &
+ 5002.66000000000 , &
+ 4986.77000000000 , &
+ 4803.78000000000 , &
+ 4800.54000000000 , &
+ 4797.28000000000 , &
+ 4793.96000000000 , &
+ 4790.18000000000 , &
+ 4785.78000000000 , &
+ 4780.71000000000 , &
+ 4775.00000000000 , &
+ 4768.58000000000 , &
+ 4761.41000000000 , &
+ 4753.51000000000 , &
+ 4744.86000000000 , &
+ 4735.64000000000 /)
+
+ Mref_V%vsh_ref( 661 : 690 ) = (/ &
+ 4725.88000000000 , &
+ 4715.76000000000 , &
+ 4705.34000000000 , &
+ 4694.74000000000 , &
+ 4684.08000000000 , &
+ 4673.46000000000 , &
+ 4662.94000000000 , &
+ 4652.61000000000 , &
+ 4642.55000000000 , &
+ 4632.81000000000 , &
+ 4623.51000000000 , &
+ 4614.68000000000 , &
+ 4606.39000000000 , &
+ 4598.73000000000 , &
+ 4591.76000000000 , &
+ 4585.56000000000 , &
+ 4580.21000000000 , &
+ 4575.75000000000 , &
+ 4575.74000000000 , &
+ 4572.27000000000 , &
+ 4569.53000000000 , &
+ 4567.46000000000 , &
+ 4566.02000000000 , &
+ 4565.10000000000 , &
+ 4564.66000000000 , &
+ 4564.65000000000 , &
+ 4564.99000000000 , &
+ 4565.62000000000 , &
+ 4566.47000000000 , &
+ 4567.46000000000 /)
+
+ Mref_V%vsh_ref( 691 : 720 ) = (/ &
+ 4568.58000000000 , &
+ 4569.70000000000 , &
+ 4570.85000000000 , &
+ 4571.91000000000 , &
+ 4572.83000000000 , &
+ 4573.60000000000 , &
+ 4574.16000000000 , &
+ 4574.44000000000 , &
+ 4574.42000000000 , &
+ 4574.04000000000 , &
+ 4573.36000000000 , &
+ 4572.41000000000 , &
+ 4572.46000000000 , &
+ 4571.71000000000 , &
+ 4570.93000000000 , &
+ 4570.06000000000 , &
+ 4569.16000000000 , &
+ 4568.21000000000 , &
+ 4567.22000000000 , &
+ 4566.21000000000 , &
+ 4565.16000000000 , &
+ 4564.11000000000 , &
+ 4563.05000000000 , &
+ 4562.00000000000 , &
+ 4560.94000000000 , &
+ 4559.94000000000 , &
+ 4558.94000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 /)
+
+ Mref_V%vsh_ref( 721 : 750 ) = (/ &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 /)
+
+ Mref_V%eta_ref( 1 : 30 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 31 : 60 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 61 : 90 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 91 : 120 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 121 : 150 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 151 : 180 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 181 : 210 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 211 : 240 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 241 : 270 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 271 : 300 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 301 : 330 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 331 : 360 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 361 : 390 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 391 : 420 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 421 : 450 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 451 : 480 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 481 : 510 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 511 : 540 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 541 : 570 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 571 : 600 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 601 : 630 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 631 : 660 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 0.999990000000000 , &
+ 0.999970000000000 , &
+ 0.999950000000000 , &
+ 0.999940000000000 , &
+ 0.999900000000000 , &
+ 0.999860000000000 , &
+ 0.999800000000000 , &
+ 0.999740000000000 , &
+ 0.999660000000000 /)
+
+ Mref_V%eta_ref( 661 : 690 ) = (/ &
+ 0.999570000000000 , &
+ 0.999470000000000 , &
+ 0.999340000000000 , &
+ 0.999200000000000 , &
+ 0.999040000000000 , &
+ 0.998860000000000 , &
+ 0.998640000000000 , &
+ 0.998320000000000 , &
+ 0.997900000000000 , &
+ 0.997320000000000 , &
+ 0.996540000000000 , &
+ 0.995530000000000 , &
+ 0.994260000000000 , &
+ 0.992680000000000 , &
+ 0.990750000000000 , &
+ 0.988430000000000 , &
+ 0.985710000000000 , &
+ 0.982550000000000 , &
+ 0.982500000000000 , &
+ 0.979070000000000 , &
+ 0.975310000000000 , &
+ 0.971280000000000 , &
+ 0.967040000000000 , &
+ 0.962680000000000 , &
+ 0.958230000000000 , &
+ 0.953780000000000 , &
+ 0.949380000000000 , &
+ 0.945090000000000 , &
+ 0.940980000000000 , &
+ 0.937120000000000 /)
+
+ Mref_V%eta_ref( 691 : 720 ) = (/ &
+ 0.933560000000000 , &
+ 0.930340000000000 , &
+ 0.927430000000000 , &
+ 0.924830000000000 , &
+ 0.922510000000000 , &
+ 0.920460000000000 , &
+ 0.918670000000000 , &
+ 0.917110000000000 , &
+ 0.915770000000000 , &
+ 0.914650000000000 , &
+ 0.913710000000000 , &
+ 0.912960000000000 , &
+ 0.912940000000000 , &
+ 0.912540000000000 , &
+ 0.912210000000000 , &
+ 0.911930000000000 , &
+ 0.911710000000000 , &
+ 0.911550000000000 , &
+ 0.911420000000000 , &
+ 0.911340000000000 , &
+ 0.911300000000000 , &
+ 0.911290000000000 , &
+ 0.911300000000000 , &
+ 0.911350000000000 , &
+ 0.911400000000000 , &
+ 0.911470000000000 , &
+ 0.911550000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 721 : 750 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+ Mref_V%density_ref(718:750) = Mref_V%density_ref(717)
+ Mref_V%vpv_ref(718:750) = Mref_V%vpv_ref(717)
+ Mref_V%vph_ref(718:750) = Mref_V%vph_ref(717)
+ Mref_V%vsv_ref(718:750) = Mref_V%vsv_ref(717)
+ Mref_V%vsh_ref(718:750) = Mref_V%vsh_ref(717)
+ endif
+
+
+ end subroutine define_model_ref
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_sea1d.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_sea1d.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_sea1d.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/model_sea1d.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,1144 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 model_sea1d(x,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+! input:
+! radius r: meters
+
+! output:
+! density rho: kg/m^3
+! compressional wave speed vp: km/s
+! shear wave speed vs: km/s
+
+ integer iregion_code
+
+ double precision x,rho,vp,vs,Qmu,Qkappa
+
+ integer i
+
+ double precision r,frac,scaleval
+
+!! DK DK UGLY implementation of model sea1d below and its radii in
+!! DK DK UGLY subroutine read_parameter_file.f90 has not been thoroughly
+!! DK DK UGLY checked yet
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+ i = 1
+ do while(r >= SEA1DM_V%radius_sea1d(i) .and. i /= NR_SEA1D)
+ i = i + 1
+ enddo
+
+! make sure we stay in the right region
+ if(iregion_code == IREGION_INNER_CORE .and. i > 13) i = 13
+
+ if(iregion_code == IREGION_OUTER_CORE .and. i < 15) i = 15
+ if(iregion_code == IREGION_OUTER_CORE .and. i > 37) i = 37
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. i < 39) i = 39
+
+ if(i == 1) then
+ rho = SEA1DM_V%density_sea1d(i)
+ vp = SEA1DM_V%vp_sea1d(i)
+ vs = SEA1DM_V%vs_sea1d(i)
+ Qmu = SEA1DM_V%Qmu_sea1d(i)
+ Qkappa = SEA1DM_V%Qkappa_sea1d(i)
+ else
+
+! interpolate from SEA1DM_V%radius_sea1d(i-1) to r using the values at i-1 and i
+ frac = (r-SEA1DM_V%radius_sea1d(i-1))/(SEA1DM_V%radius_sea1d(i)-SEA1DM_V%radius_sea1d(i-1))
+
+ rho = SEA1DM_V%density_sea1d(i-1) + frac * (SEA1DM_V%density_sea1d(i)-SEA1DM_V%density_sea1d(i-1))
+ vp = SEA1DM_V%vp_sea1d(i-1) + frac * (SEA1DM_V%vp_sea1d(i)-SEA1DM_V%vp_sea1d(i-1))
+ vs = SEA1DM_V%vs_sea1d(i-1) + frac * (SEA1DM_V%vs_sea1d(i)-SEA1DM_V%vs_sea1d(i-1))
+ Qmu = SEA1DM_V%Qmu_sea1d(i-1) + frac * (SEA1DM_V%Qmu_sea1d(i)-SEA1DM_V%Qmu_sea1d(i-1))
+ Qkappa = SEA1DM_V%Qkappa_sea1d(i-1) + frac * (SEA1DM_V%Qkappa_sea1d(i)-SEA1DM_V%Qkappa_sea1d(i-1))
+
+ endif
+
+! make sure Vs is zero in the outer core even if roundoff errors on depth
+! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
+ if(iregion_code == IREGION_OUTER_CORE) then
+ vs = 0.d0
+ Qkappa = 3000.d0
+ Qmu = 3000.d0
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine model_sea1d
+
+!-------------------
+
+ subroutine define_model_sea1d(USE_EXTERNAL_CRUSTAL_MODEL,SEA1DM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+! three_d_mantle_model_variables
+
+ logical USE_EXTERNAL_CRUSTAL_MODEL
+
+ integer i
+
+! define all the values in the model
+
+ SEA1DM_V%radius_sea1d(1)= 0.0000000000
+ SEA1DM_V%radius_sea1d(2)= 101425.0000000000
+ SEA1DM_V%radius_sea1d(3)= 202850.0000000000
+ SEA1DM_V%radius_sea1d(4)= 304275.0000000000
+ SEA1DM_V%radius_sea1d(5)= 405700.0000000000
+ SEA1DM_V%radius_sea1d(6)= 507125.0000000000
+ SEA1DM_V%radius_sea1d(7)= 608550.0000000000
+ SEA1DM_V%radius_sea1d(8)= 709975.0000000000
+ SEA1DM_V%radius_sea1d(9)= 811400.0000000000
+ SEA1DM_V%radius_sea1d(10)= 912825.0000000000
+ SEA1DM_V%radius_sea1d(11)= 1014250.0000000000
+ SEA1DM_V%radius_sea1d(12)= 1115675.0000000000
+ SEA1DM_V%radius_sea1d(13)= 1217100.0000000000
+ SEA1DM_V%radius_sea1d(14)= 1217100.0000000000
+ SEA1DM_V%radius_sea1d(15)= 1315735.0000000000
+ SEA1DM_V%radius_sea1d(16)= 1414370.0000000000
+ SEA1DM_V%radius_sea1d(17)= 1513004.0000000000
+ SEA1DM_V%radius_sea1d(18)= 1611639.0000000000
+ SEA1DM_V%radius_sea1d(19)= 1710274.0000000000
+ SEA1DM_V%radius_sea1d(20)= 1808909.0000000000
+ SEA1DM_V%radius_sea1d(21)= 1907544.0000000000
+ SEA1DM_V%radius_sea1d(22)= 2006178.0000000000
+ SEA1DM_V%radius_sea1d(23)= 2104813.0000000000
+ SEA1DM_V%radius_sea1d(24)= 2203448.0000000000
+ SEA1DM_V%radius_sea1d(25)= 2302082.0000000000
+ SEA1DM_V%radius_sea1d(26)= 2400717.0000000000
+ SEA1DM_V%radius_sea1d(27)= 2499352.0000000000
+ SEA1DM_V%radius_sea1d(28)= 2597987.0000000000
+ SEA1DM_V%radius_sea1d(29)= 2696622.0000000000
+ SEA1DM_V%radius_sea1d(30)= 2795256.0000000000
+ SEA1DM_V%radius_sea1d(31)= 2893891.0000000000
+ SEA1DM_V%radius_sea1d(32)= 2992526.0000000000
+ SEA1DM_V%radius_sea1d(33)= 3091161.0000000000
+ SEA1DM_V%radius_sea1d(34)= 3189796.0000000000
+ SEA1DM_V%radius_sea1d(35)= 3288431.0000000000
+ SEA1DM_V%radius_sea1d(36)= 3387066.0000000000
+ SEA1DM_V%radius_sea1d(37)= 3485700.0000000000
+ SEA1DM_V%radius_sea1d(38)= 3485700.0000000000
+ SEA1DM_V%radius_sea1d(39)= 3536048.0000000000
+ SEA1DM_V%radius_sea1d(40)= 3586396.0000000000
+ SEA1DM_V%radius_sea1d(41)= 3636743.0000000000
+ SEA1DM_V%radius_sea1d(42)= 3687091.0000000000
+ SEA1DM_V%radius_sea1d(43)= 3737438.0000000000
+ SEA1DM_V%radius_sea1d(44)= 3787786.0000000000
+ SEA1DM_V%radius_sea1d(45)= 3838134.0000000000
+ SEA1DM_V%radius_sea1d(46)= 3888482.0000000000
+ SEA1DM_V%radius_sea1d(47)= 3938830.0000000000
+ SEA1DM_V%radius_sea1d(48)= 3989177.0000000000
+ SEA1DM_V%radius_sea1d(49)= 4039525.0000000000
+ SEA1DM_V%radius_sea1d(50)= 4089872.0000000000
+ SEA1DM_V%radius_sea1d(51)= 4140220.0000000000
+ SEA1DM_V%radius_sea1d(52)= 4190568.0000000000
+ SEA1DM_V%radius_sea1d(53)= 4240916.0000000000
+ SEA1DM_V%radius_sea1d(54)= 4291264.0000000000
+ SEA1DM_V%radius_sea1d(55)= 4341612.0000000000
+ SEA1DM_V%radius_sea1d(56)= 4391959.0000000000
+ SEA1DM_V%radius_sea1d(57)= 4442306.0000000000
+ SEA1DM_V%radius_sea1d(58)= 4492654.0000000000
+ SEA1DM_V%radius_sea1d(59)= 4543002.0000000000
+ SEA1DM_V%radius_sea1d(60)= 4593350.0000000000
+ SEA1DM_V%radius_sea1d(61)= 4643698.0000000000
+ SEA1DM_V%radius_sea1d(62)= 4694046.0000000000
+ SEA1DM_V%radius_sea1d(63)= 4744393.0000000000
+ SEA1DM_V%radius_sea1d(64)= 4794740.0000000000
+ SEA1DM_V%radius_sea1d(65)= 4845089.0000000000
+ SEA1DM_V%radius_sea1d(66)= 4895436.0000000000
+ SEA1DM_V%radius_sea1d(67)= 4945784.0000000000
+ SEA1DM_V%radius_sea1d(68)= 4996132.0000000000
+ SEA1DM_V%radius_sea1d(69)= 5046480.0000000000
+ SEA1DM_V%radius_sea1d(70)= 5096827.0000000000
+ SEA1DM_V%radius_sea1d(71)= 5147175.0000000000
+ SEA1DM_V%radius_sea1d(72)= 5197522.0000000000
+ SEA1DM_V%radius_sea1d(73)= 5247870.0000000000
+ SEA1DM_V%radius_sea1d(74)= 5298218.0000000000
+ SEA1DM_V%radius_sea1d(75)= 5348566.0000000000
+ SEA1DM_V%radius_sea1d(76)= 5398914.0000000000
+ SEA1DM_V%radius_sea1d(77)= 5449261.0000000000
+ SEA1DM_V%radius_sea1d(78)= 5499610.0000000000
+ SEA1DM_V%radius_sea1d(79)= 5549957.0000000000
+ SEA1DM_V%radius_sea1d(80)= 5600304.0000000000
+ SEA1DM_V%radius_sea1d(81)= 5650652.0000000000
+ SEA1DM_V%radius_sea1d(82)= 5701000.0000000000
+ SEA1DM_V%radius_sea1d(83)= 5711000.0000000000
+ SEA1DM_V%radius_sea1d(84)= 5711000.0000000000
+ SEA1DM_V%radius_sea1d(85)= 5721000.0000000000
+ SEA1DM_V%radius_sea1d(86)= 5731000.0000000000
+ SEA1DM_V%radius_sea1d(87)= 5741000.0000000000
+ SEA1DM_V%radius_sea1d(88)= 5751000.0000000000
+ SEA1DM_V%radius_sea1d(89)= 5761000.0000000000
+ SEA1DM_V%radius_sea1d(90)= 5771000.0000000000
+ SEA1DM_V%radius_sea1d(91)= 5781000.0000000000
+ SEA1DM_V%radius_sea1d(92)= 5791000.0000000000
+ SEA1DM_V%radius_sea1d(93)= 5801000.0000000000
+ SEA1DM_V%radius_sea1d(94)= 5811000.0000000000
+ SEA1DM_V%radius_sea1d(95)= 5821000.0000000000
+ SEA1DM_V%radius_sea1d(96)= 5831000.0000000000
+ SEA1DM_V%radius_sea1d(97)= 5841000.0000000000
+ SEA1DM_V%radius_sea1d(98)= 5851000.0000000000
+ SEA1DM_V%radius_sea1d(99)= 5861000.0000000000
+ SEA1DM_V%radius_sea1d(100)= 5871000.0000000000
+ SEA1DM_V%radius_sea1d(101)= 5881000.0000000000
+ SEA1DM_V%radius_sea1d(102)= 5891000.0000000000
+ SEA1DM_V%radius_sea1d(103)= 5901000.0000000000
+ SEA1DM_V%radius_sea1d(104)= 5911000.0000000000
+ SEA1DM_V%radius_sea1d(105)= 5921000.0000000000
+ SEA1DM_V%radius_sea1d(106)= 5931000.0000000000
+ SEA1DM_V%radius_sea1d(107)= 5941000.0000000000
+ SEA1DM_V%radius_sea1d(108)= 5951000.0000000000
+ SEA1DM_V%radius_sea1d(109)= 5961000.0000000000
+ SEA1DM_V%radius_sea1d(110)= 5961000.0000000000
+ SEA1DM_V%radius_sea1d(111)= 5971000.0000000000
+ SEA1DM_V%radius_sea1d(112)= 5981000.0000000000
+ SEA1DM_V%radius_sea1d(113)= 5991000.0000000000
+ SEA1DM_V%radius_sea1d(114)= 6001000.0000000000
+ SEA1DM_V%radius_sea1d(115)= 6011000.0000000000
+ SEA1DM_V%radius_sea1d(116)= 6021000.0000000000
+ SEA1DM_V%radius_sea1d(117)= 6031000.0000000000
+ SEA1DM_V%radius_sea1d(118)= 6041000.0000000000
+ SEA1DM_V%radius_sea1d(119)= 6051000.0000000000
+ SEA1DM_V%radius_sea1d(120)= 6061000.0000000000
+ SEA1DM_V%radius_sea1d(121)= 6071000.0000000000
+ SEA1DM_V%radius_sea1d(122)= 6081000.0000000000
+ SEA1DM_V%radius_sea1d(123)= 6091000.0000000000
+ SEA1DM_V%radius_sea1d(124)= 6101000.0000000000
+ SEA1DM_V%radius_sea1d(125)= 6111000.0000000000
+ SEA1DM_V%radius_sea1d(126)= 6121000.0000000000
+ SEA1DM_V%radius_sea1d(127)= 6131000.0000000000
+ SEA1DM_V%radius_sea1d(128)= 6141000.0000000000
+ SEA1DM_V%radius_sea1d(129)= 6151000.0000000000
+ SEA1DM_V%radius_sea1d(130)= 6161000.0000000000
+ SEA1DM_V%radius_sea1d(131)= 6171000.0000000000
+ SEA1DM_V%radius_sea1d(132)= 6181000.0000000000
+ SEA1DM_V%radius_sea1d(133)= 6191000.0000000000
+ SEA1DM_V%radius_sea1d(134)= 6201000.0000000000
+ SEA1DM_V%radius_sea1d(135)= 6211000.0000000000
+ SEA1DM_V%radius_sea1d(136)= 6221000.0000000000
+ SEA1DM_V%radius_sea1d(137)= 6231000.0000000000
+ SEA1DM_V%radius_sea1d(138)= 6241000.0000000000
+ SEA1DM_V%radius_sea1d(139)= 6251000.0000000000
+ SEA1DM_V%radius_sea1d(140)= 6261000.0000000000
+ SEA1DM_V%radius_sea1d(141)= 6271000.0000000000
+ SEA1DM_V%radius_sea1d(142)= 6281000.0000000000
+ SEA1DM_V%radius_sea1d(143)= 6291000.0000000000
+ SEA1DM_V%radius_sea1d(144)= 6301000.0000000000
+ SEA1DM_V%radius_sea1d(145)= 6311000.0000000000
+ SEA1DM_V%radius_sea1d(146)= 6321000.0000000000
+ SEA1DM_V%radius_sea1d(147)= 6326000.0000000000
+ SEA1DM_V%radius_sea1d(148)= 6331000.0000000000
+ SEA1DM_V%radius_sea1d(149)= 6336000.0000000000
+ SEA1DM_V%radius_sea1d(150)= 6341000.0000000000
+ SEA1DM_V%radius_sea1d(151)= 6346000.0000000000
+ SEA1DM_V%radius_sea1d(152)= 6346000.0000000000
+ SEA1DM_V%radius_sea1d(153)= 6351000.0000000000
+ SEA1DM_V%radius_sea1d(154)= 6353800.0000000000
+ SEA1DM_V%radius_sea1d(155)= 6356600.0000000000
+ SEA1DM_V%radius_sea1d(156)= 6360000.0000000000
+ SEA1DM_V%radius_sea1d(157)= 6363000.0000000000
+ SEA1DM_V%radius_sea1d(158)= 6365000.0000000000
+ SEA1DM_V%radius_sea1d(159)= 6366000.0000000000
+ SEA1DM_V%radius_sea1d(160)= 6366000.0000000000
+ SEA1DM_V%radius_sea1d(161)= 6368000.0000000000
+ SEA1DM_V%radius_sea1d(162)= 6368000.0000000000
+ SEA1DM_V%radius_sea1d(163)= 6371000.0000000000
+
+ SEA1DM_V%density_sea1d(1)= 13.0121900000000
+ SEA1DM_V%density_sea1d(2)= 13.0100200000000
+ SEA1DM_V%density_sea1d(3)= 13.0035600000000
+ SEA1DM_V%density_sea1d(4)= 12.9928300000000
+ SEA1DM_V%density_sea1d(5)= 12.9778000000000
+ SEA1DM_V%density_sea1d(6)= 12.9585000000000
+ SEA1DM_V%density_sea1d(7)= 12.9349100000000
+ SEA1DM_V%density_sea1d(8)= 12.9070300000000
+ SEA1DM_V%density_sea1d(9)= 12.8748700000000
+ SEA1DM_V%density_sea1d(10)= 12.8384300000000
+ SEA1DM_V%density_sea1d(11)= 12.7977100000000
+ SEA1DM_V%density_sea1d(12)= 12.7526900000000
+ SEA1DM_V%density_sea1d(13)= 12.7037000000000
+ SEA1DM_V%density_sea1d(14)= 12.1391000000000
+ SEA1DM_V%density_sea1d(15)= 12.0877600000000
+ SEA1DM_V%density_sea1d(16)= 12.0333900000000
+ SEA1DM_V%density_sea1d(17)= 11.9757900000000
+ SEA1DM_V%density_sea1d(18)= 11.9148500000000
+ SEA1DM_V%density_sea1d(19)= 11.8503900000000
+ SEA1DM_V%density_sea1d(20)= 11.7822500000000
+ SEA1DM_V%density_sea1d(21)= 11.7102700000000
+ SEA1DM_V%density_sea1d(22)= 11.6343000000000
+ SEA1DM_V%density_sea1d(23)= 11.5541800000000
+ SEA1DM_V%density_sea1d(24)= 11.4697400000000
+ SEA1DM_V%density_sea1d(25)= 11.3808400000000
+ SEA1DM_V%density_sea1d(26)= 11.2873100000000
+ SEA1DM_V%density_sea1d(27)= 11.1890000000000
+ SEA1DM_V%density_sea1d(28)= 11.0857400000000
+ SEA1DM_V%density_sea1d(29)= 10.9773800000000
+ SEA1DM_V%density_sea1d(30)= 10.8637600000000
+ SEA1DM_V%density_sea1d(31)= 10.7447200000000
+ SEA1DM_V%density_sea1d(32)= 10.6201000000000
+ SEA1DM_V%density_sea1d(33)= 10.4897500000000
+ SEA1DM_V%density_sea1d(34)= 10.3535000000000
+ SEA1DM_V%density_sea1d(35)= 10.2112100000000
+ SEA1DM_V%density_sea1d(36)= 10.0627000000000
+ SEA1DM_V%density_sea1d(37)= 9.9085500000000
+ SEA1DM_V%density_sea1d(38)= 5.5497800000000
+ SEA1DM_V%density_sea1d(39)= 5.5263200000000
+ SEA1DM_V%density_sea1d(40)= 5.5027000000000
+ SEA1DM_V%density_sea1d(41)= 5.4789400000000
+ SEA1DM_V%density_sea1d(42)= 5.4550400000000
+ SEA1DM_V%density_sea1d(43)= 5.4309700000000
+ SEA1DM_V%density_sea1d(44)= 5.4067700000000
+ SEA1DM_V%density_sea1d(45)= 5.3824200000000
+ SEA1DM_V%density_sea1d(46)= 5.3579200000000
+ SEA1DM_V%density_sea1d(47)= 5.3332700000000
+ SEA1DM_V%density_sea1d(48)= 5.3084700000000
+ SEA1DM_V%density_sea1d(49)= 5.2835200000000
+ SEA1DM_V%density_sea1d(50)= 5.2584400000000
+ SEA1DM_V%density_sea1d(51)= 5.2331900000000
+ SEA1DM_V%density_sea1d(52)= 5.2078000000000
+ SEA1DM_V%density_sea1d(53)= 5.1822700000000
+ SEA1DM_V%density_sea1d(54)= 5.1565900000000
+ SEA1DM_V%density_sea1d(55)= 5.1307500000000
+ SEA1DM_V%density_sea1d(56)= 5.1047600000000
+ SEA1DM_V%density_sea1d(57)= 5.0786400000000
+ SEA1DM_V%density_sea1d(58)= 5.0523600000000
+ SEA1DM_V%density_sea1d(59)= 5.0259400000000
+ SEA1DM_V%density_sea1d(60)= 4.9993600000000
+ SEA1DM_V%density_sea1d(61)= 4.9726500000000
+ SEA1DM_V%density_sea1d(62)= 4.9457800000000
+ SEA1DM_V%density_sea1d(63)= 4.9187500000000
+ SEA1DM_V%density_sea1d(64)= 4.8915900000000
+ SEA1DM_V%density_sea1d(65)= 4.8642700000000
+ SEA1DM_V%density_sea1d(66)= 4.8368200000000
+ SEA1DM_V%density_sea1d(67)= 4.8092100000000
+ SEA1DM_V%density_sea1d(68)= 4.7814400000000
+ SEA1DM_V%density_sea1d(69)= 4.7535400000000
+ SEA1DM_V%density_sea1d(70)= 4.7254900000000
+ SEA1DM_V%density_sea1d(71)= 4.6972900000000
+ SEA1DM_V%density_sea1d(72)= 4.6689400000000
+ SEA1DM_V%density_sea1d(73)= 4.6404400000000
+ SEA1DM_V%density_sea1d(74)= 4.6117900000000
+ SEA1DM_V%density_sea1d(75)= 4.5830000000000
+ SEA1DM_V%density_sea1d(76)= 4.5540600000000
+ SEA1DM_V%density_sea1d(77)= 4.5249700000000
+ SEA1DM_V%density_sea1d(78)= 4.4957300000000
+ SEA1DM_V%density_sea1d(79)= 4.4663500000000
+ SEA1DM_V%density_sea1d(80)= 4.4368100000000
+ SEA1DM_V%density_sea1d(81)= 4.4071300000000
+ SEA1DM_V%density_sea1d(82)= 4.3773100000000
+ SEA1DM_V%density_sea1d(83)= 4.3713900000000
+ SEA1DM_V%density_sea1d(84)= 4.0645800000000
+ SEA1DM_V%density_sea1d(85)= 4.0522200000000
+ SEA1DM_V%density_sea1d(86)= 4.0398700000000
+ SEA1DM_V%density_sea1d(87)= 4.0275200000000
+ SEA1DM_V%density_sea1d(88)= 4.0151600000000
+ SEA1DM_V%density_sea1d(89)= 4.0028100000000
+ SEA1DM_V%density_sea1d(90)= 3.9904500000000
+ SEA1DM_V%density_sea1d(91)= 3.9781000000000
+ SEA1DM_V%density_sea1d(92)= 3.9657500000000
+ SEA1DM_V%density_sea1d(93)= 3.9533900000000
+ SEA1DM_V%density_sea1d(94)= 3.9410400000000
+ SEA1DM_V%density_sea1d(95)= 3.9286900000000
+ SEA1DM_V%density_sea1d(96)= 3.9163300000000
+ SEA1DM_V%density_sea1d(97)= 3.9039800000000
+ SEA1DM_V%density_sea1d(98)= 3.8916200000000
+ SEA1DM_V%density_sea1d(99)= 3.8792700000000
+ SEA1DM_V%density_sea1d(100)= 3.8669200000000
+ SEA1DM_V%density_sea1d(101)= 3.8545600000000
+ SEA1DM_V%density_sea1d(102)= 3.8422100000000
+ SEA1DM_V%density_sea1d(103)= 3.8298600000000
+ SEA1DM_V%density_sea1d(104)= 3.8175000000000
+ SEA1DM_V%density_sea1d(105)= 3.8051500000000
+ SEA1DM_V%density_sea1d(106)= 3.7928000000000
+ SEA1DM_V%density_sea1d(107)= 3.7804400000000
+ SEA1DM_V%density_sea1d(108)= 3.7680900000000
+ SEA1DM_V%density_sea1d(109)= 3.7557300000000
+ SEA1DM_V%density_sea1d(110)= 3.5469600000000
+ SEA1DM_V%density_sea1d(111)= 3.5409000000000
+ SEA1DM_V%density_sea1d(112)= 3.5348400000000
+ SEA1DM_V%density_sea1d(113)= 3.5287900000000
+ SEA1DM_V%density_sea1d(114)= 3.5227300000000
+ SEA1DM_V%density_sea1d(115)= 3.5166700000000
+ SEA1DM_V%density_sea1d(116)= 3.5106100000000
+ SEA1DM_V%density_sea1d(117)= 3.5045500000000
+ SEA1DM_V%density_sea1d(118)= 3.4984900000000
+ SEA1DM_V%density_sea1d(119)= 3.4924300000000
+ SEA1DM_V%density_sea1d(120)= 3.4863800000000
+ SEA1DM_V%density_sea1d(121)= 3.4803200000000
+ SEA1DM_V%density_sea1d(122)= 3.4742600000000
+ SEA1DM_V%density_sea1d(123)= 3.4682000000000
+ SEA1DM_V%density_sea1d(124)= 3.4621400000000
+ SEA1DM_V%density_sea1d(125)= 3.4560800000000
+ SEA1DM_V%density_sea1d(126)= 3.4500200000000
+ SEA1DM_V%density_sea1d(127)= 3.4439700000000
+ SEA1DM_V%density_sea1d(128)= 3.4379100000000
+ SEA1DM_V%density_sea1d(129)= 3.4318500000000
+ SEA1DM_V%density_sea1d(130)= 3.4257900000000
+ SEA1DM_V%density_sea1d(131)= 3.4197300000000
+ SEA1DM_V%density_sea1d(132)= 3.4136800000000
+ SEA1DM_V%density_sea1d(133)= 3.4076200000000
+ SEA1DM_V%density_sea1d(134)= 3.4015600000000
+ SEA1DM_V%density_sea1d(135)= 3.3955000000000
+ SEA1DM_V%density_sea1d(136)= 3.3894400000000
+ SEA1DM_V%density_sea1d(137)= 3.3833800000000
+ SEA1DM_V%density_sea1d(138)= 3.3773200000000
+ SEA1DM_V%density_sea1d(139)= 3.3712600000000
+ SEA1DM_V%density_sea1d(140)= 3.3652100000000
+ SEA1DM_V%density_sea1d(141)= 3.3591500000000
+ SEA1DM_V%density_sea1d(142)= 3.3530900000000
+ SEA1DM_V%density_sea1d(143)= 3.3470300000000
+ SEA1DM_V%density_sea1d(144)= 3.3409700000000
+ SEA1DM_V%density_sea1d(145)= 3.3349100000000
+ SEA1DM_V%density_sea1d(146)= 3.3288500000000
+ SEA1DM_V%density_sea1d(147)= 3.3288500000000
+ SEA1DM_V%density_sea1d(148)= 3.3227900000000
+ SEA1DM_V%density_sea1d(149)= 3.3227900000000
+ SEA1DM_V%density_sea1d(150)= 3.3227900000000
+ SEA1DM_V%density_sea1d(151)= 3.3227900000000
+ SEA1DM_V%density_sea1d(152)= 2.8500000000000
+ SEA1DM_V%density_sea1d(153)= 2.8500000000000
+ SEA1DM_V%density_sea1d(154)= 2.8500000000000
+ SEA1DM_V%density_sea1d(155)= 2.8500000000000
+ SEA1DM_V%density_sea1d(156)= 2.8500000000000
+ SEA1DM_V%density_sea1d(157)= 2.8500000000000
+ SEA1DM_V%density_sea1d(158)= 2.8500000000000
+ SEA1DM_V%density_sea1d(159)= 2.8500000000000
+ SEA1DM_V%density_sea1d(160)= 2.8500000000000
+ SEA1DM_V%density_sea1d(161)= 2.8500000000000
+ SEA1DM_V%density_sea1d(162)= 2.8500000000000
+ SEA1DM_V%density_sea1d(163)= 2.8500000000000
+
+ SEA1DM_V%vp_sea1d(1)= 11.2409400000000
+ SEA1DM_V%vp_sea1d(2)= 11.2398900000000
+ SEA1DM_V%vp_sea1d(3)= 11.2367600000000
+ SEA1DM_V%vp_sea1d(4)= 11.2315600000000
+ SEA1DM_V%vp_sea1d(5)= 11.2242700000000
+ SEA1DM_V%vp_sea1d(6)= 11.2149200000000
+ SEA1DM_V%vp_sea1d(7)= 11.2034800000000
+ SEA1DM_V%vp_sea1d(8)= 11.1899700000000
+ SEA1DM_V%vp_sea1d(9)= 11.1743800000000
+ SEA1DM_V%vp_sea1d(10)= 11.1567200000000
+ SEA1DM_V%vp_sea1d(11)= 11.1369900000000
+ SEA1DM_V%vp_sea1d(12)= 11.1151700000000
+ SEA1DM_V%vp_sea1d(13)= 11.0914200000000
+ SEA1DM_V%vp_sea1d(14)= 10.2577900000000
+ SEA1DM_V%vp_sea1d(15)= 10.2317700000000
+ SEA1DM_V%vp_sea1d(16)= 10.1991900000000
+ SEA1DM_V%vp_sea1d(17)= 10.1600600000000
+ SEA1DM_V%vp_sea1d(18)= 10.1143700000000
+ SEA1DM_V%vp_sea1d(19)= 10.0621400000000
+ SEA1DM_V%vp_sea1d(20)= 10.0033600000000
+ SEA1DM_V%vp_sea1d(21)= 9.9380100000000
+ SEA1DM_V%vp_sea1d(22)= 9.8661300000000
+ SEA1DM_V%vp_sea1d(23)= 9.7876800000000
+ SEA1DM_V%vp_sea1d(24)= 9.7026900000000
+ SEA1DM_V%vp_sea1d(25)= 9.6111500000000
+ SEA1DM_V%vp_sea1d(26)= 9.5130500000000
+ SEA1DM_V%vp_sea1d(27)= 9.4084000000000
+ SEA1DM_V%vp_sea1d(28)= 9.2972000000000
+ SEA1DM_V%vp_sea1d(29)= 9.1794500000000
+ SEA1DM_V%vp_sea1d(30)= 9.0551400000000
+ SEA1DM_V%vp_sea1d(31)= 8.9242800000000
+ SEA1DM_V%vp_sea1d(32)= 8.7868700000000
+ SEA1DM_V%vp_sea1d(33)= 8.6429000000000
+ SEA1DM_V%vp_sea1d(34)= 8.4923900000000
+ SEA1DM_V%vp_sea1d(35)= 8.3353300000000
+ SEA1DM_V%vp_sea1d(36)= 8.1717000000000
+ SEA1DM_V%vp_sea1d(37)= 8.0022600000000
+ SEA1DM_V%vp_sea1d(38)= 13.7318200000000
+ SEA1DM_V%vp_sea1d(39)= 13.6839600000000
+ SEA1DM_V%vp_sea1d(40)= 13.6355700000000
+ SEA1DM_V%vp_sea1d(41)= 13.5866700000000
+ SEA1DM_V%vp_sea1d(42)= 13.5372000000000
+ SEA1DM_V%vp_sea1d(43)= 13.4871700000000
+ SEA1DM_V%vp_sea1d(44)= 13.4365700000000
+ SEA1DM_V%vp_sea1d(45)= 13.3853700000000
+ SEA1DM_V%vp_sea1d(46)= 13.3335400000000
+ SEA1DM_V%vp_sea1d(47)= 13.2811000000000
+ SEA1DM_V%vp_sea1d(48)= 13.2280100000000
+ SEA1DM_V%vp_sea1d(49)= 13.1742700000000
+ SEA1DM_V%vp_sea1d(50)= 13.1198500000000
+ SEA1DM_V%vp_sea1d(51)= 13.0647300000000
+ SEA1DM_V%vp_sea1d(52)= 13.0089100000000
+ SEA1DM_V%vp_sea1d(53)= 12.9523700000000
+ SEA1DM_V%vp_sea1d(54)= 12.8951000000000
+ SEA1DM_V%vp_sea1d(55)= 12.8370600000000
+ SEA1DM_V%vp_sea1d(56)= 12.7782600000000
+ SEA1DM_V%vp_sea1d(57)= 12.7186700000000
+ SEA1DM_V%vp_sea1d(58)= 12.6582800000000
+ SEA1DM_V%vp_sea1d(59)= 12.5970700000000
+ SEA1DM_V%vp_sea1d(60)= 12.5350400000000
+ SEA1DM_V%vp_sea1d(61)= 12.4721600000000
+ SEA1DM_V%vp_sea1d(62)= 12.4084000000000
+ SEA1DM_V%vp_sea1d(63)= 12.3437700000000
+ SEA1DM_V%vp_sea1d(64)= 12.2782500000000
+ SEA1DM_V%vp_sea1d(65)= 12.2118200000000
+ SEA1DM_V%vp_sea1d(66)= 12.1444600000000
+ SEA1DM_V%vp_sea1d(67)= 12.0761600000000
+ SEA1DM_V%vp_sea1d(68)= 12.0069000000000
+ SEA1DM_V%vp_sea1d(69)= 11.9366700000000
+ SEA1DM_V%vp_sea1d(70)= 11.8654400000000
+ SEA1DM_V%vp_sea1d(71)= 11.7932100000000
+ SEA1DM_V%vp_sea1d(72)= 11.7199700000000
+ SEA1DM_V%vp_sea1d(73)= 11.6456800000000
+ SEA1DM_V%vp_sea1d(74)= 11.5703400000000
+ SEA1DM_V%vp_sea1d(75)= 11.4939400000000
+ SEA1DM_V%vp_sea1d(76)= 11.4164500000000
+ SEA1DM_V%vp_sea1d(77)= 11.3378700000000
+ SEA1DM_V%vp_sea1d(78)= 11.2581700000000
+ SEA1DM_V%vp_sea1d(79)= 11.1773300000000
+ SEA1DM_V%vp_sea1d(80)= 11.0953600000000
+ SEA1DM_V%vp_sea1d(81)= 11.0122200000000
+ SEA1DM_V%vp_sea1d(82)= 10.9280200000000
+ SEA1DM_V%vp_sea1d(83)= 10.9113000000000
+ SEA1DM_V%vp_sea1d(84)= 10.0182900000000
+ SEA1DM_V%vp_sea1d(85)= 9.9989600000000
+ SEA1DM_V%vp_sea1d(86)= 9.9796300000000
+ SEA1DM_V%vp_sea1d(87)= 9.9603000000000
+ SEA1DM_V%vp_sea1d(88)= 9.9409700000000
+ SEA1DM_V%vp_sea1d(89)= 9.9216400000000
+ SEA1DM_V%vp_sea1d(90)= 9.9023100000000
+ SEA1DM_V%vp_sea1d(91)= 9.8829800000000
+ SEA1DM_V%vp_sea1d(92)= 9.8636600000000
+ SEA1DM_V%vp_sea1d(93)= 9.8443300000000
+ SEA1DM_V%vp_sea1d(94)= 9.8250000000000
+ SEA1DM_V%vp_sea1d(95)= 9.8056700000000
+ SEA1DM_V%vp_sea1d(96)= 9.7863400000000
+ SEA1DM_V%vp_sea1d(97)= 9.7670100000000
+ SEA1DM_V%vp_sea1d(98)= 9.7476800000000
+ SEA1DM_V%vp_sea1d(99)= 9.7283500000000
+ SEA1DM_V%vp_sea1d(100)= 9.7090300000000
+ SEA1DM_V%vp_sea1d(101)= 9.6897000000000
+ SEA1DM_V%vp_sea1d(102)= 9.6703700000000
+ SEA1DM_V%vp_sea1d(103)= 9.6510400000000
+ SEA1DM_V%vp_sea1d(104)= 9.6317100000000
+ SEA1DM_V%vp_sea1d(105)= 9.6123800000000
+ SEA1DM_V%vp_sea1d(106)= 9.5930500000000
+ SEA1DM_V%vp_sea1d(107)= 9.5737200000000
+ SEA1DM_V%vp_sea1d(108)= 9.5543900000000
+ SEA1DM_V%vp_sea1d(109)= 9.5350600000000
+ SEA1DM_V%vp_sea1d(110)= 9.0766800000000
+ SEA1DM_V%vp_sea1d(111)= 9.0188500000000
+ SEA1DM_V%vp_sea1d(112)= 8.9610200000000
+ SEA1DM_V%vp_sea1d(113)= 8.9031800000000
+ SEA1DM_V%vp_sea1d(114)= 8.8453500000000
+ SEA1DM_V%vp_sea1d(115)= 8.7875100000000
+ SEA1DM_V%vp_sea1d(116)= 8.7296800000000
+ SEA1DM_V%vp_sea1d(117)= 8.6718500000000
+ SEA1DM_V%vp_sea1d(118)= 8.6140100000000
+ SEA1DM_V%vp_sea1d(119)= 8.5561800000000
+ SEA1DM_V%vp_sea1d(120)= 8.4983400000000
+ SEA1DM_V%vp_sea1d(121)= 8.4405100000000
+ SEA1DM_V%vp_sea1d(122)= 8.3826700000000
+ SEA1DM_V%vp_sea1d(123)= 8.3248400000000
+ SEA1DM_V%vp_sea1d(124)= 8.2670100000000
+ SEA1DM_V%vp_sea1d(125)= 8.2091700000000
+ SEA1DM_V%vp_sea1d(126)= 8.1513400000000
+ SEA1DM_V%vp_sea1d(127)= 8.0935000000000
+ SEA1DM_V%vp_sea1d(128)= 8.0356700000000
+ SEA1DM_V%vp_sea1d(129)= 7.9778300000000
+ SEA1DM_V%vp_sea1d(130)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(131)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(132)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(133)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(134)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(135)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(136)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(137)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(138)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(139)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(140)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(141)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(142)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(143)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(144)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(145)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(146)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(147)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(148)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(149)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(150)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(151)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(152)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(153)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(154)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(155)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(156)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(157)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(158)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(159)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(160)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(161)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(162)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(163)= 6.4000000000000
+
+ SEA1DM_V%vs_sea1d(1)= 3.5645400000000
+ SEA1DM_V%vs_sea1d(2)= 3.5636500000000
+ SEA1DM_V%vs_sea1d(3)= 3.5610200000000
+ SEA1DM_V%vs_sea1d(4)= 3.5566300000000
+ SEA1DM_V%vs_sea1d(5)= 3.5504900000000
+ SEA1DM_V%vs_sea1d(6)= 3.5426100000000
+ SEA1DM_V%vs_sea1d(7)= 3.5329700000000
+ SEA1DM_V%vs_sea1d(8)= 3.5215900000000
+ SEA1DM_V%vs_sea1d(9)= 3.5084500000000
+ SEA1DM_V%vs_sea1d(10)= 3.4935700000000
+ SEA1DM_V%vs_sea1d(11)= 3.4769300000000
+ SEA1DM_V%vs_sea1d(12)= 3.4585500000000
+ SEA1DM_V%vs_sea1d(13)= 3.4385400000000
+ SEA1DM_V%vs_sea1d(14)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(15)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(16)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(17)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(18)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(19)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(20)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(21)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(22)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(23)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(24)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(25)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(26)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(27)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(28)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(29)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(30)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(31)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(32)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(33)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(34)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(35)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(36)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(37)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(38)= 7.2433800000000
+ SEA1DM_V%vs_sea1d(39)= 7.2260300000000
+ SEA1DM_V%vs_sea1d(40)= 7.2085500000000
+ SEA1DM_V%vs_sea1d(41)= 7.1909200000000
+ SEA1DM_V%vs_sea1d(42)= 7.1731300000000
+ SEA1DM_V%vs_sea1d(43)= 7.1551600000000
+ SEA1DM_V%vs_sea1d(44)= 7.1370000000000
+ SEA1DM_V%vs_sea1d(45)= 7.1186000000000
+ SEA1DM_V%vs_sea1d(46)= 7.0999800000000
+ SEA1DM_V%vs_sea1d(47)= 7.0810900000000
+ SEA1DM_V%vs_sea1d(48)= 7.0619300000000
+ SEA1DM_V%vs_sea1d(49)= 7.0424700000000
+ SEA1DM_V%vs_sea1d(50)= 7.0227000000000
+ SEA1DM_V%vs_sea1d(51)= 7.0026000000000
+ SEA1DM_V%vs_sea1d(52)= 6.9821500000000
+ SEA1DM_V%vs_sea1d(53)= 6.9613400000000
+ SEA1DM_V%vs_sea1d(54)= 6.9401300000000
+ SEA1DM_V%vs_sea1d(55)= 6.9185200000000
+ SEA1DM_V%vs_sea1d(56)= 6.8964900000000
+ SEA1DM_V%vs_sea1d(57)= 6.8740200000000
+ SEA1DM_V%vs_sea1d(58)= 6.8510900000000
+ SEA1DM_V%vs_sea1d(59)= 6.8276700000000
+ SEA1DM_V%vs_sea1d(60)= 6.8037600000000
+ SEA1DM_V%vs_sea1d(61)= 6.7793300000000
+ SEA1DM_V%vs_sea1d(62)= 6.7543700000000
+ SEA1DM_V%vs_sea1d(63)= 6.7288500000000
+ SEA1DM_V%vs_sea1d(64)= 6.7027700000000
+ SEA1DM_V%vs_sea1d(65)= 6.6760900000000
+ SEA1DM_V%vs_sea1d(66)= 6.6488100000000
+ SEA1DM_V%vs_sea1d(67)= 6.6208900000000
+ SEA1DM_V%vs_sea1d(68)= 6.5923300000000
+ SEA1DM_V%vs_sea1d(69)= 6.5631100000000
+ SEA1DM_V%vs_sea1d(70)= 6.5332000000000
+ SEA1DM_V%vs_sea1d(71)= 6.5026000000000
+ SEA1DM_V%vs_sea1d(72)= 6.4712600000000
+ SEA1DM_V%vs_sea1d(73)= 6.4392000000000
+ SEA1DM_V%vs_sea1d(74)= 6.4063800000000
+ SEA1DM_V%vs_sea1d(75)= 6.3727800000000
+ SEA1DM_V%vs_sea1d(76)= 6.3383900000000
+ SEA1DM_V%vs_sea1d(77)= 6.3031900000000
+ SEA1DM_V%vs_sea1d(78)= 6.2671500000000
+ SEA1DM_V%vs_sea1d(79)= 6.2302600000000
+ SEA1DM_V%vs_sea1d(80)= 6.1925100000000
+ SEA1DM_V%vs_sea1d(81)= 6.1538700000000
+ SEA1DM_V%vs_sea1d(82)= 6.1144200000000
+ SEA1DM_V%vs_sea1d(83)= 6.1065800000000
+ SEA1DM_V%vs_sea1d(84)= 5.4546300000000
+ SEA1DM_V%vs_sea1d(85)= 5.4378400000000
+ SEA1DM_V%vs_sea1d(86)= 5.4210500000000
+ SEA1DM_V%vs_sea1d(87)= 5.4042500000000
+ SEA1DM_V%vs_sea1d(88)= 5.3874600000000
+ SEA1DM_V%vs_sea1d(89)= 5.3706700000000
+ SEA1DM_V%vs_sea1d(90)= 5.3538800000000
+ SEA1DM_V%vs_sea1d(91)= 5.3370900000000
+ SEA1DM_V%vs_sea1d(92)= 5.3203000000000
+ SEA1DM_V%vs_sea1d(93)= 5.3035100000000
+ SEA1DM_V%vs_sea1d(94)= 5.2867200000000
+ SEA1DM_V%vs_sea1d(95)= 5.2699300000000
+ SEA1DM_V%vs_sea1d(96)= 5.2531400000000
+ SEA1DM_V%vs_sea1d(97)= 5.2363500000000
+ SEA1DM_V%vs_sea1d(98)= 5.2195600000000
+ SEA1DM_V%vs_sea1d(99)= 5.2027700000000
+ SEA1DM_V%vs_sea1d(100)= 5.1859800000000
+ SEA1DM_V%vs_sea1d(101)= 5.1691900000000
+ SEA1DM_V%vs_sea1d(102)= 5.1524000000000
+ SEA1DM_V%vs_sea1d(103)= 5.1356100000000
+ SEA1DM_V%vs_sea1d(104)= 5.1188200000000
+ SEA1DM_V%vs_sea1d(105)= 5.1020200000000
+ SEA1DM_V%vs_sea1d(106)= 5.0852300000000
+ SEA1DM_V%vs_sea1d(107)= 5.0684400000000
+ SEA1DM_V%vs_sea1d(108)= 5.0516500000000
+ SEA1DM_V%vs_sea1d(109)= 5.0348600000000
+ SEA1DM_V%vs_sea1d(110)= 4.7959100000000
+ SEA1DM_V%vs_sea1d(111)= 4.7761200000000
+ SEA1DM_V%vs_sea1d(112)= 4.7563200000000
+ SEA1DM_V%vs_sea1d(113)= 4.7365300000000
+ SEA1DM_V%vs_sea1d(114)= 4.7167300000000
+ SEA1DM_V%vs_sea1d(115)= 4.6969400000000
+ SEA1DM_V%vs_sea1d(116)= 4.6771400000000
+ SEA1DM_V%vs_sea1d(117)= 4.6573400000000
+ SEA1DM_V%vs_sea1d(118)= 4.6375500000000
+ SEA1DM_V%vs_sea1d(119)= 4.6177500000000
+ SEA1DM_V%vs_sea1d(120)= 4.5979600000000
+ SEA1DM_V%vs_sea1d(121)= 4.5781600000000
+ SEA1DM_V%vs_sea1d(122)= 4.5583700000000
+ SEA1DM_V%vs_sea1d(123)= 4.5385700000000
+ SEA1DM_V%vs_sea1d(124)= 4.5187700000000
+ SEA1DM_V%vs_sea1d(125)= 4.4989800000000
+ SEA1DM_V%vs_sea1d(126)= 4.4791800000000
+ SEA1DM_V%vs_sea1d(127)= 4.4593900000000
+ SEA1DM_V%vs_sea1d(128)= 4.4395900000000
+ SEA1DM_V%vs_sea1d(129)= 4.4198000000000
+ SEA1DM_V%vs_sea1d(130)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(131)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(132)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(133)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(134)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(135)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(136)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(137)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(138)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(139)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(140)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(141)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(142)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(143)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(144)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(145)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(146)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(147)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(148)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(149)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(150)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(151)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(152)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(153)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(154)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(155)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(156)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(157)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(158)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(159)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(160)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(161)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(162)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(163)= 3.4500000000000
+
+ SEA1DM_V%Qkappa_sea1d(1)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(2)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(3)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(4)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(5)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(6)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(7)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(8)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(9)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(10)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(11)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(12)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(13)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(14)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(15)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(16)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(17)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(18)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(19)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(20)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(21)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(22)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(23)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(24)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(25)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(26)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(27)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(28)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(29)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(30)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(31)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(32)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(33)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(34)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(35)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(36)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(37)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(38)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(39)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(40)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(41)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(42)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(43)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(44)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(45)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(46)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(47)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(48)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(49)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(50)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(51)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(52)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(53)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(54)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(55)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(56)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(57)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(58)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(59)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(60)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(61)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(62)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(63)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(64)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(65)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(66)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(67)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(68)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(69)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(70)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(71)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(72)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(73)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(74)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(75)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(76)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(77)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(78)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(79)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(80)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(81)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(82)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(83)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(84)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(85)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(86)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(87)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(88)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(89)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(90)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(91)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(92)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(93)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(94)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(95)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(96)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(97)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(98)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(99)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(100)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(101)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(102)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(103)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(104)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(105)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(106)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(107)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(108)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(109)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(110)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(111)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(112)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(113)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(114)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(115)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(116)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(117)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(118)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(119)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(120)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(121)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(122)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(123)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(124)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(125)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(126)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(127)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(128)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(129)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(130)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(131)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(132)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(133)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(134)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(135)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(136)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(137)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(138)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(139)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(140)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(141)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(142)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(143)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(144)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(145)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(146)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(147)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(148)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(149)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(150)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(151)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(152)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(153)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(154)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(155)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(156)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(157)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(158)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(159)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(160)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(161)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(162)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(163)= 99999.0000000000000
+
+ SEA1DM_V%Qmu_sea1d(1)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(2)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(3)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(4)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(5)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(6)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(7)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(8)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(9)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(10)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(11)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(12)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(13)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(14)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(15)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(16)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(17)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(18)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(19)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(20)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(21)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(22)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(23)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(24)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(25)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(26)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(27)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(28)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(29)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(30)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(31)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(32)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(33)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(34)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(35)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(36)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(37)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(38)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(39)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(40)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(41)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(42)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(43)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(44)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(45)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(46)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(47)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(48)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(49)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(50)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(51)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(52)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(53)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(54)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(55)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(56)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(57)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(58)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(59)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(60)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(61)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(62)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(63)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(64)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(65)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(66)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(67)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(68)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(69)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(70)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(71)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(72)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(73)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(74)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(75)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(76)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(77)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(78)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(79)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(80)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(81)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(82)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(83)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(84)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(85)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(86)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(87)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(88)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(89)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(90)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(91)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(92)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(93)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(94)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(95)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(96)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(97)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(98)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(99)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(100)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(101)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(102)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(103)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(104)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(105)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(106)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(107)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(108)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(109)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(110)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(111)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(112)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(113)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(114)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(115)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(116)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(117)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(118)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(119)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(120)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(121)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(122)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(123)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(124)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(125)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(126)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(127)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(128)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(129)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(130)= 110.0000000000000
+ SEA1DM_V%Qmu_sea1d(131)= 80.0000000000000
+ SEA1DM_V%Qmu_sea1d(132)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(133)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(134)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(135)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(136)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(137)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(138)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(139)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(140)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(141)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(142)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(143)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(144)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(145)= 100.0000000000000
+ SEA1DM_V%Qmu_sea1d(146)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(147)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(148)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(149)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(150)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(151)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(152)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(153)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(154)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(155)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(156)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(157)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(158)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(159)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(160)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(161)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(162)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(163)= 300.0000000000000
+
+! strip the crust and replace it by mantle
+ if(USE_EXTERNAL_CRUSTAL_MODEL) then
+ do i=NR_SEA1D-12,NR_SEA1D
+ SEA1DM_V%density_sea1d(i) = SEA1DM_V%density_sea1d(NR_SEA1D-13)
+ SEA1DM_V%vp_sea1d(i) = SEA1DM_V%vp_sea1d(NR_SEA1D-13)
+ SEA1DM_V%vs_sea1d(i) = SEA1DM_V%vs_sea1d(NR_SEA1D-13)
+ SEA1DM_V%Qkappa_sea1d(i) = SEA1DM_V%Qkappa_sea1d(NR_SEA1D-13)
+ SEA1DM_V%Qmu_sea1d(i) = SEA1DM_V%Qmu_sea1d(NR_SEA1D-13)
+ enddo
+ endif
+
+ end subroutine define_model_sea1d
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/moho_stretching.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/moho_stretching.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/moho_stretching.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/moho_stretching.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,301 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220)
+
+ implicit none
+
+ include "constants.h"
+
+! ocean-continent function maximum spherical harmonic degree
+ integer, parameter :: NL_OCEAN_CONTINENT = 12
+
+! spherical harmonic coefficients of the ocean-continent function (km)
+ double precision A_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT),B_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT)
+
+ common /smooth_moho/ A_lm,B_lm
+
+ integer myrank
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision RMOHO,R220
+
+ integer ia
+
+ integer l,m
+ double precision r,theta,phi
+ double precision sint,cost,x(2*NL_OCEAN_CONTINENT+1),dx(2*NL_OCEAN_CONTINENT+1)
+ double precision elevation
+ double precision gamma
+
+! we loop on all the points of the element
+ do ia = 1,NGNOD
+
+! convert to r theta phi
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+ call reduce(theta,phi)
+
+ elevation = 0.0d0
+ do l = 0,NL_OCEAN_CONTINENT
+ sint = dsin(theta)
+ cost = dcos(theta)
+ call lgndr(l,cost,sint,x,dx)
+ m = 0
+ elevation = elevation + A_lm(l,m)*x(m+1)
+ do m = 1,l
+ elevation = elevation + (A_lm(l,m)*dcos(dble(m)*phi)+B_lm(l,m)*dsin(dble(m)*phi))*x(m+1)
+ enddo
+ enddo
+ elevation = -0.25d0*elevation/R_EARTH_KM
+
+ gamma = 0.0d0
+ if(r >= RMOHO/R_EARTH) then
+! stretching above the Moho
+ gamma = (1.0d0 - r) / (1.0d0 - RMOHO/R_EARTH)
+ elseif(r>= R220/R_EARTH .and. r< RMOHO/R_EARTH) then
+! stretching between R220 and RMOHO
+ gamma = (r - R220/R_EARTH) / (RMOHO/R_EARTH - R220/R_EARTH)
+ endif
+ if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for Moho topography')
+
+ xelm(ia) = xelm(ia)*(ONE + gamma * elevation / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * elevation / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * elevation / r)
+
+ enddo
+
+ end subroutine moho_stretching
+
+ subroutine read_smooth_moho
+
+ implicit none
+
+! ocean-continent function maximum spherical harmonic degree
+ integer, parameter :: NL_OCEAN_CONTINENT = 12
+
+! spherical harmonic coefficients of the ocean-continent function (km)
+ double precision A_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT),B_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT)
+
+ common /smooth_moho/ A_lm,B_lm
+
+! integer l,m
+!
+! ocean-continent function (km)
+! open(unit=10,file='DATA/ocean_continent_function/ocean_continent_function.txt',status='old',action='read')
+! do l=0,NL_OCEAN_CONTINENT
+! read(10,*) A_lm(l,0),(A_lm(l,m),B_lm(l,m),m=1,l)
+! enddo
+! close(10)
+
+ A_lm(0,0) = -3.8201999E-04
+ B_lm(0,0) = 0.
+ A_lm(1,0) = 13.88800
+ B_lm(1,0) = 0.
+ A_lm(1,1) = -15.24000
+ B_lm(1,1) = -9.187200
+ A_lm(2,0) = 11.21500
+ B_lm(2,0) = 0.
+ A_lm(2,1) = -6.754500
+ B_lm(2,1) = -8.516700
+ A_lm(2,2) = -8.327800
+ B_lm(2,2) = -5.029200
+ A_lm(3,0) = -3.614500
+ B_lm(3,0) = 0.
+ A_lm(3,1) = 5.394800
+ B_lm(3,1) = -0.9220800
+ A_lm(3,2) = -10.05100
+ B_lm(3,2) = 13.98100
+ A_lm(3,3) = -2.711200
+ B_lm(3,3) = -13.57100
+ A_lm(4,0) = 7.523300
+ B_lm(4,0) = 0.
+ A_lm(4,1) = 5.156100
+ B_lm(4,1) = 2.184400
+ A_lm(4,2) = -10.67300
+ B_lm(4,2) = 2.640600
+ A_lm(4,3) = -7.786300
+ B_lm(4,3) = 0.3674500
+ A_lm(4,4) = -3.076400
+ B_lm(4,4) = 16.83000
+ A_lm(5,0) = -9.681000
+ B_lm(5,0) = 0.
+ A_lm(5,1) = 0.5026800
+ B_lm(5,1) = 2.111300
+ A_lm(5,2) = -2.931000
+ B_lm(5,2) = -4.329000
+ A_lm(5,3) = -1.766800
+ B_lm(5,3) = -3.621200
+ A_lm(5,4) = 16.08200
+ B_lm(5,4) = -4.493900
+ A_lm(5,5) = -0.3705800
+ B_lm(5,5) = -5.574500
+ A_lm(6,0) = 4.407900
+ B_lm(6,0) = 0.
+ A_lm(6,1) = 0.3799000
+ B_lm(6,1) = 1.589400
+ A_lm(6,2) = -1.886400
+ B_lm(6,2) = -0.5686300
+ A_lm(6,3) = -0.9816800
+ B_lm(6,3) = -5.827800
+ A_lm(6,4) = 3.620600
+ B_lm(6,4) = -2.713100
+ A_lm(6,5) = 1.445600
+ B_lm(6,5) = 3.964100
+ A_lm(6,6) = 1.167400
+ B_lm(6,6) = 2.134100
+ A_lm(7,0) = -4.086100
+ B_lm(7,0) = 0.
+ A_lm(7,1) = 0.5462000
+ B_lm(7,1) = -4.488100
+ A_lm(7,2) = 3.116400
+ B_lm(7,2) = 1.793600
+ A_lm(7,3) = 2.594600
+ B_lm(7,3) = -2.129100
+ A_lm(7,4) = -5.445000
+ B_lm(7,4) = 0.5381500
+ A_lm(7,5) = -2.178100
+ B_lm(7,5) = 1.766700
+ A_lm(7,6) = -1.040000
+ B_lm(7,6) = -5.541000
+ A_lm(7,7) = 1.536500
+ B_lm(7,7) = 3.700600
+ A_lm(8,0) = -2.562200
+ B_lm(8,0) = 0.
+ A_lm(8,1) = 0.3736200
+ B_lm(8,1) = 1.488000
+ A_lm(8,2) = 1.347500
+ B_lm(8,2) = 0.5288200
+ A_lm(8,3) = -0.8493700
+ B_lm(8,3) = -1.626500
+ A_lm(8,4) = 0.2423400
+ B_lm(8,4) = 4.202800
+ A_lm(8,5) = 2.052200
+ B_lm(8,5) = 0.6880400
+ A_lm(8,6) = 2.838500
+ B_lm(8,6) = 2.835700
+ A_lm(8,7) = -4.981400
+ B_lm(8,7) = -1.883100
+ A_lm(8,8) = -1.102800
+ B_lm(8,8) = -1.951700
+ A_lm(9,0) = -1.202100
+ B_lm(9,0) = 0.
+ A_lm(9,1) = 1.020300
+ B_lm(9,1) = 1.371000
+ A_lm(9,2) = -0.3430100
+ B_lm(9,2) = 0.8782800
+ A_lm(9,3) = -0.4462500
+ B_lm(9,3) = -0.3046100
+ A_lm(9,4) = 0.7750700
+ B_lm(9,4) = 2.351600
+ A_lm(9,5) = -2.092600
+ B_lm(9,5) = -2.377100
+ A_lm(9,6) = 0.3126900
+ B_lm(9,6) = 4.996000
+ A_lm(9,7) = -2.284000
+ B_lm(9,7) = 1.183700
+ A_lm(9,8) = 1.445900
+ B_lm(9,8) = 1.080000
+ A_lm(9,9) = 1.146700
+ B_lm(9,9) = 1.457800
+ A_lm(10,0) = -2.516900
+ B_lm(10,0) = 0.
+ A_lm(10,1) = -0.9739500
+ B_lm(10,1) = -0.7195500
+ A_lm(10,2) = -2.846000
+ B_lm(10,2) = -1.464700
+ A_lm(10,3) = 2.720100
+ B_lm(10,3) = 0.8241400
+ A_lm(10,4) = -1.247800
+ B_lm(10,4) = 1.220300
+ A_lm(10,5) = -1.638500
+ B_lm(10,5) = -1.099500
+ A_lm(10,6) = 3.043000
+ B_lm(10,6) = -1.976400
+ A_lm(10,7) = -1.007300
+ B_lm(10,7) = -1.604900
+ A_lm(10,8) = 0.6620500
+ B_lm(10,8) = -1.135000
+ A_lm(10,9) = -3.576800
+ B_lm(10,9) = 0.5554900
+ A_lm(10,10) = 2.418700
+ B_lm(10,10) = -1.482200
+ A_lm(11,0) = 0.7158800
+ B_lm(11,0) = 0.
+ A_lm(11,1) = -3.694800
+ B_lm(11,1) = 0.8491400
+ A_lm(11,2) = 9.3208998E-02
+ B_lm(11,2) = -1.276000
+ A_lm(11,3) = 1.575600
+ B_lm(11,3) = 0.1972100
+ A_lm(11,4) = 0.8989600
+ B_lm(11,4) = -1.063000
+ A_lm(11,5) = -0.6301000
+ B_lm(11,5) = -1.329400
+ A_lm(11,6) = 1.389000
+ B_lm(11,6) = 1.184100
+ A_lm(11,7) = 0.5640700
+ B_lm(11,7) = 2.286200
+ A_lm(11,8) = 1.530300
+ B_lm(11,8) = 0.7677500
+ A_lm(11,9) = 0.8495500
+ B_lm(11,9) = 0.7247500
+ A_lm(11,10) = 2.106800
+ B_lm(11,10) = 0.6588000
+ A_lm(11,11) = 0.6067800
+ B_lm(11,11) = 0.1366800
+ A_lm(12,0) = -2.598700
+ B_lm(12,0) = 0.
+ A_lm(12,1) = -1.150500
+ B_lm(12,1) = -0.8425700
+ A_lm(12,2) = -0.1593300
+ B_lm(12,2) = -1.241400
+ A_lm(12,3) = 1.508600
+ B_lm(12,3) = 0.3385500
+ A_lm(12,4) = -1.941200
+ B_lm(12,4) = 1.120000
+ A_lm(12,5) = -0.4630500
+ B_lm(12,5) = -6.4753003E-02
+ A_lm(12,6) = 0.8967000
+ B_lm(12,6) = 4.7417998E-02
+ A_lm(12,7) = 4.5407999E-02
+ B_lm(12,7) = 0.8876400
+ A_lm(12,8) = -2.444400
+ B_lm(12,8) = 1.172500
+ A_lm(12,9) = -2.593400
+ B_lm(12,9) = 0.1703700
+ A_lm(12,10) = 0.5662700
+ B_lm(12,10) = 0.7050800
+ A_lm(12,11) = -0.1930000
+ B_lm(12,11) = -2.008100
+ A_lm(12,12) = -3.187900
+ B_lm(12,12) = -1.672000
+
+ end subroutine read_smooth_moho
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/netlib_specfun_erf.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/netlib_specfun_erf.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/netlib_specfun_erf.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/netlib_specfun_erf.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,318 @@
+
+ subroutine calerf(ARG,RESULT,JINT)
+
+!------------------------------------------------------------------
+!
+! This routine can be freely obtained from Netlib
+! at http://www.netlib.org/specfun/erf
+!
+! Most Netlib software packages have no restrictions on their use
+! but Netlib recommends that you check with the authors to be sure.
+! See http://www.netlib.org/misc/faq.html#2.3 for details.
+!
+!------------------------------------------------------------------
+!
+! This packet evaluates erf(x) for a real argument x.
+! It contains one FUNCTION type subprogram: ERF,
+! and one SUBROUTINE type subprogram, CALERF. The calling
+! statements for the primary entries are:
+!
+! Y = ERF(X)
+!
+! The routine CALERF is intended for internal packet use only,
+! all computations within the packet being concentrated in this
+! routine. The function subprograms invoke CALERF with the
+! statement
+!
+! call CALERF(ARG,RESULT,JINT)
+!
+! where the parameter usage is as follows
+!
+! Function Parameters for CALERF
+! call ARG Result JINT
+!
+! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0
+!
+! The main computation evaluates near-minimax approximations
+! from "Rational Chebyshev approximations for the error function"
+! by William J. Cody, Math. Comp., 1969, PP. 631-638. This
+! transportable program uses rational functions that theoretically
+! approximate erf(x) and erfc(x) to at least 18 significant
+! decimal digits. The accuracy achieved depends on the arithmetic
+! system, the compiler, the intrinsic functions, and proper
+! selection of the machine-dependent constants.
+!
+!*******************************************************************
+!*******************************************************************
+!
+! Explanation of machine-dependent constants
+!
+! XMIN = the smallest positive floating-point number.
+! XINF = the largest positive finite floating-point number.
+! XNEG = the largest negative argument acceptable to ERFCX;
+! the negative of the solution to the equation
+! 2*exp(x*x) = XINF.
+! XSMALL = argument below which erf(x) may be represented by
+! 2*x/sqrt(pi) and above which x*x will not underflow.
+! A conservative value is the largest machine number X
+! such that 1.0 + X = 1.0 to machine precision.
+! XBIG = largest argument acceptable to ERFC; solution to
+! the equation: W(x) * (1-0.5/x**2) = XMIN, where
+! W(x) = exp(-x*x)/[x*sqrt(pi)].
+! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to
+! machine precision. A conservative value is
+! 1/[2*sqrt(XSMALL)]
+! XMAX = largest acceptable argument to ERFCX; the minimum
+! of XINF and 1/[sqrt(pi)*XMIN].
+!
+! Approximate IEEE double precision values are defined below.
+!
+!*******************************************************************
+!*******************************************************************
+!
+! Error returns
+!
+! The program returns ERFC = 0 for ARG >= XBIG;
+!
+! Author: William J. Cody
+! Mathematics and Computer Science Division
+! Argonne National Laboratory
+! Argonne, IL 60439, USA
+!
+! Latest modification: March 19, 1990
+!
+! Converted to Fortran90 and slightly modified by
+! Dimitri Komatitsch, University of Pau, France, November 2007.
+!
+!------------------------------------------------------------------
+
+ implicit none
+
+ integer I,JINT
+ double precision A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEEN,SQRPI, &
+ TWO,THRESHOLD,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL, &
+ Y,YSQ,ZERO
+ dimension A(5),B(4),C(9),D(8),P(6),Q(5)
+
+!------------------------------------------------------------------
+! Mathematical constants
+!------------------------------------------------------------------
+ data FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/, &
+ SQRPI/5.6418958354775628695D-1/,THRESHOLD/0.46875D0/, &
+ SIXTEEN/16.0D0/
+
+!------------------------------------------------------------------
+! Machine-dependent constants
+!------------------------------------------------------------------
+ data XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/, &
+ XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erf in first interval
+!------------------------------------------------------------------
+ data A/3.16112374387056560D00,1.13864154151050156D02, &
+ 3.77485237685302021D02,3.20937758913846947D03, &
+ 1.85777706184603153D-1/
+ data B/2.36012909523441209D01,2.44024637934444173D02, &
+ 1.28261652607737228D03,2.84423683343917062D03/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erfc in second interval
+!------------------------------------------------------------------
+ data C/5.64188496988670089D-1,8.88314979438837594D0, &
+ 6.61191906371416295D01,2.98635138197400131D02, &
+ 8.81952221241769090D02,1.71204761263407058D03, &
+ 2.05107837782607147D03,1.23033935479799725D03, &
+ 2.15311535474403846D-8/
+ data D/1.57449261107098347D01,1.17693950891312499D02, &
+ 5.37181101862009858D02,1.62138957456669019D03, &
+ 3.29079923573345963D03,4.36261909014324716D03, &
+ 3.43936767414372164D03,1.23033935480374942D03/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erfc in third interval
+!------------------------------------------------------------------
+ data P/3.05326634961232344D-1,3.60344899949804439D-1, &
+ 1.25781726111229246D-1,1.60837851487422766D-2, &
+ 6.58749161529837803D-4,1.63153871373020978D-2/
+ data Q/2.56852019228982242D00,1.87295284992346047D00, &
+ 5.27905102951428412D-1,6.05183413124413191D-2, &
+ 2.33520497626869185D-3/
+
+ X = ARG
+ Y = ABS(X)
+ if (Y <= THRESHOLD) then
+
+!------------------------------------------------------------------
+! Evaluate erf for |X| <= 0.46875
+!------------------------------------------------------------------
+ YSQ = ZERO
+ if (Y > XSMALL) YSQ = Y * Y
+ XNUM = A(5)*YSQ
+ XDEN = YSQ
+
+ do I = 1, 3
+ XNUM = (XNUM + A(I)) * YSQ
+ XDEN = (XDEN + B(I)) * YSQ
+ enddo
+
+ RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
+ if (JINT /= 0) RESULT = ONE - RESULT
+ if (JINT == 2) RESULT = EXP(YSQ) * RESULT
+ goto 800
+
+!------------------------------------------------------------------
+! Evaluate erfc for 0.46875 <= |X| <= 4.0
+!------------------------------------------------------------------
+ else if (Y <= FOUR) then
+ XNUM = C(9)*Y
+ XDEN = Y
+
+ do I = 1, 7
+ XNUM = (XNUM + C(I)) * Y
+ XDEN = (XDEN + D(I)) * Y
+ enddo
+
+ RESULT = (XNUM + C(8)) / (XDEN + D(8))
+ if (JINT /= 2) then
+ YSQ = AINT(Y*SIXTEEN)/SIXTEEN
+ DEL = (Y-YSQ)*(Y+YSQ)
+ RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+ endif
+
+!------------------------------------------------------------------
+! Evaluate erfc for |X| > 4.0
+!------------------------------------------------------------------
+ else
+ RESULT = ZERO
+ if (Y >= XBIG) then
+ if (JINT /= 2 .OR. Y >= XMAX) goto 300
+ if (Y >= XHUGE) then
+ RESULT = SQRPI / Y
+ goto 300
+ endif
+ endif
+ YSQ = ONE / (Y * Y)
+ XNUM = P(6)*YSQ
+ XDEN = YSQ
+
+ do I = 1, 4
+ XNUM = (XNUM + P(I)) * YSQ
+ XDEN = (XDEN + Q(I)) * YSQ
+ enddo
+
+ RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
+ RESULT = (SQRPI - RESULT) / Y
+ if (JINT /= 2) then
+ YSQ = AINT(Y*SIXTEEN)/SIXTEEN
+ DEL = (Y-YSQ)*(Y+YSQ)
+ RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+ endif
+ endif
+
+!------------------------------------------------------------------
+! Fix up for negative argument, erf, etc.
+!------------------------------------------------------------------
+ 300 if (JINT == 0) then
+ RESULT = (HALF - RESULT) + HALF
+ if (X < ZERO) RESULT = -RESULT
+ else if (JINT == 1) then
+ if (X < ZERO) RESULT = TWO - RESULT
+ else
+ if (X < ZERO) then
+ if (X < XNEG) then
+ RESULT = XINF
+ else
+ YSQ = AINT(X*SIXTEEN)/SIXTEEN
+ DEL = (X-YSQ)*(X+YSQ)
+ Y = EXP(YSQ*YSQ) * EXP(DEL)
+ RESULT = (Y+Y) - RESULT
+ endif
+ endif
+ endif
+
+ 800 return
+
+ end subroutine calerf
+
+!--------------------------------------------------------------------
+
+ double precision function netlib_specfun_erf(X)
+
+! This subprogram computes approximate values for erf(x).
+! (see comments heading CALERF).
+!
+! Author/date: William J. Cody, January 8, 1985
+
+ implicit none
+
+ integer JINT
+ double precision X, RESULT
+
+ JINT = 0
+ call calerf(X,RESULT,JINT)
+ netlib_specfun_erf = RESULT
+
+ end function netlib_specfun_erf
+
+!
+! Subject: RE: Can one freely use and redistribute Fortran routines "specfun" from Netlib?
+! From: Jack Dongarra
+! Date: Wed, 21 Nov 2007 10:33:45 -0500
+! To: Rusty Lusk, Dimitri Komatitsch
+!
+! Yes the code can freely be used and incorporated into other software. You
+! should of course acknowledge the use of the software.
+!
+! Hope this helps,
+!
+! Jack Dongarra
+!
+! **********************************************************************
+! Prof. Jack Dongarra; Innovative Computing Laboratory; EECS Department;
+! 1122 Volunteer Blvd; University of Tennessee; Knoxville TN 37996-3450;
+! +1-865-974-8295; http://www.cs.utk.edu/~dongarra/
+!
+! -----Original Message-----
+! From: Rusty Lusk
+! Sent: Wednesday, November 21, 2007 10:29 AM
+! To: Dimitri Komatitsch
+! Cc: Jack Dongarra
+! Subject: Re: Can one freely use and redistribute Fortran routines "specfun"
+! from Netlib?
+!
+! Netlib is managed at the University of Tennesee, not Argonne at this
+! point. I have copied Jack Dongarra on this reply; he should be able
+! to answer questions about licensing issues for code from Netlib.
+!
+! Regards,
+! Rusty
+!
+! On Nov 21, 2007, at 8:36 AM, Dimitri Komatitsch wrote:
+!
+! >
+! > Dear Sir,
+! >
+! > Can one freely use and redistribute Fortran routines "specfun" from
+! > Netlib http://netlib2.cs.utk.edu/specfun/
+! > which were written back in 1985-1990 by William J. Cody
+! > from the Mathematics and Computer Science Division at Argonne?
+! >
+! > We use one of these routines (the error function, erf())
+! > in one of our source codes, which we would like to
+! > release as open source under GPL v2+, and we therefore
+! > wonder if we could include that erf() routine in the
+! > package in a separate file (of course saying in a comment in the
+! > header that it comes from Netlib and was written by William J. Cody from
+! > Argonne).
+! >
+! > Thank you,
+! > Best regards,
+! >
+! > Dimitri Komatitsch.
+! >
+! > --
+! > Dimitri Komatitsch - dimitri.komatitsch aT univ-pau.fr
+! > Professor, University of Pau, Institut universitaire de France
+! > and INRIA Magique3D, France http://www.univ-pau.fr/~dkomati1
+! >
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,2506 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,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
+
+ 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,LOCAL_PATH,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_region_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'
+
+ 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
+
+! 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)
+
+!! DK DK suppressed because this routine should not write anything to the screen
+! write(*,*)'##############################################################'
+! write(*,*)
+! write(*,*)' Auto Radial Meshing Code '
+! write(*,*)' Consult read_compute_parameters.f90 and auto_ner.f90 '
+! write(*,*)' This should only be invoked for chunks less than 90 degrees'
+! write(*,*)' and for chunks greater than 1248 elements wide'
+! write(*,*)
+! write(*,*)'CHUNK WIDTH: ', ANGULAR_WIDTH_XI_IN_DEGREES
+! write(*,*)'NEX: ', NEX_MAX
+! write(*,*)'NER_CRUST: ', NER_CRUST
+! write(*,*)'NER_80_MOHO: ', NER_80_MOHO
+! write(*,*)'NER_220_80: ', NER_220_80
+! write(*,*)'NER_400_220: ', NER_400_220
+! write(*,*)'NER_600_400: ', NER_600_400
+! write(*,*)'NER_670_600: ', NER_670_600
+! write(*,*)'NER_771_670: ', NER_771_670
+! write(*,*)'NER_TOPDDOUBLEPRIME_771: ', NER_TOPDDOUBLEPRIME_771
+! write(*,*)'NER_CMB_TOPDDOUBLEPRIME: ', NER_CMB_TOPDDOUBLEPRIME
+! write(*,*)'NER_OUTER_CORE: ', NER_OUTER_CORE
+! write(*,*)'NER_TOP_CENTRAL_CUBE_ICB: ', NER_TOP_CENTRAL_CUBE_ICB
+! write(*,*)'R_CENTRAL_CUBE: ', R_CENTRAL_CUBE
+! write(*,*)'multiplication factor: ', multiplication_factor
+! write(*,*)
+! write(*,*)'DT: ',DT
+! write(*,*)'MIN_ATTENUATION_PERIOD ',MIN_ATTENUATION_PERIOD
+! write(*,*)'MAX_ATTENUATION_PERIOD ',MAX_ATTENUATION_PERIOD
+! write(*,*)
+! write(*,*)'##############################################################'
+
+ 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'
+
+! 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_string(LOCAL_PATH, 'LOCAL_PATH')
+ 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
+
+ ! 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_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(10) = .true.
+ this_region_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
+
+ ! 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_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(2) = .true.
+ this_region_has_a_doubling(9) = .true.
+ this_region_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
+
+ ! 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_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(3) = .true.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ this_region_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
+
+ ! 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_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ this_region_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
+
+ ! 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_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(2) = .true.
+ this_region_has_a_doubling(9) = .true.
+ this_region_has_a_doubling(12) = .true.
+ this_region_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
+
+ ! 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_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(3) = .true.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ this_region_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_region_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_region_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_region_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
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_value_parameters.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_value_parameters.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_value_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_value_parameters.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,179 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! read values from parameter file, ignoring white lines and comments
+
+ subroutine read_value_integer(value_to_read, name)
+
+ implicit none
+
+ integer value_to_read
+ character(len=*) name
+ character(len=100) string_read
+
+ call unused_string(name)
+
+ call read_next_line(string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_integer
+
+!--------------------
+
+ subroutine read_value_double_precision(value_to_read, name)
+
+ implicit none
+
+ double precision value_to_read
+ character(len=*) name
+ character(len=100) string_read
+
+ call unused_string(name)
+
+ call read_next_line(string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_double_precision
+
+!--------------------
+
+ subroutine read_value_logical(value_to_read, name)
+
+ implicit none
+
+ logical value_to_read
+ character(len=*) name
+ character(len=100) string_read
+
+ call unused_string(name)
+
+ call read_next_line(string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_logical
+
+!--------------------
+
+ subroutine read_value_string(value_to_read, name)
+
+ implicit none
+
+ character(len=*) value_to_read
+ character(len=*) name
+ character(len=100) string_read
+
+ call unused_string(name)
+
+ call read_next_line(string_read)
+ value_to_read = string_read
+
+ end subroutine read_value_string
+
+!--------------------
+
+ subroutine read_next_line(string_read)
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=100) string_read
+
+ integer index_equal_sign,ios
+
+ do
+ read(unit=IIN,fmt="(a100)",iostat=ios) string_read
+ if(ios /= 0) stop 'error while reading parameter file'
+
+! suppress leading white spaces, if any
+ string_read = adjustl(string_read)
+
+! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS)
+ if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1)
+
+! exit loop when we find the first line that is not a comment or a white line
+ if(len_trim(string_read) == 0) cycle
+ if(string_read(1:1) /= '#') exit
+
+ enddo
+
+! suppress trailing white spaces, if any
+ string_read = string_read(1:len_trim(string_read))
+
+! suppress trailing comments, if any
+ if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1)
+
+! suppress leading junk (up to the first equal sign, included)
+ index_equal_sign = index(string_read,'=')
+ if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file'
+ string_read = string_read(index_equal_sign + 1:len_trim(string_read))
+
+! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk
+ string_read = adjustl(string_read)
+ string_read = string_read(1:len_trim(string_read))
+
+ end subroutine read_next_line
+
+!--------------------
+
+ subroutine open_parameter_file
+
+ include "constants.h"
+
+ open(unit=IIN,file='DATA/Par_file',status='old',action='read')
+
+ end subroutine open_parameter_file
+
+!--------------------
+
+ subroutine close_parameter_file
+
+ include "constants.h"
+
+ close(IIN)
+
+ end subroutine close_parameter_file
+
+!--------------------
+
+ integer function err_occurred()
+
+ err_occurred = 0
+
+ end function err_occurred
+
+!--------------------
+
+! dummy subroutine to avoid warnings about variable not used in other subroutines
+ subroutine unused_string(s)
+
+ character(len=*) s
+
+ if (len(s) == 1) continue
+
+ end subroutine unused_string
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/recompute_jacobian.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_jacobian.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/recompute_jacobian.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/recompute_jacobian.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,267 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! recompute 3D jacobian at a given point for 27-node elements
+
+ subroutine recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision x,y,z,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ double precision xi,eta,gamma,jacobian
+
+! coordinates of the control points of the surface element
+ double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
+
+! 3D shape functions and their derivatives at receiver
+ double precision shape3D(NGNOD)
+ double precision dershape3D(NDIM,NGNOD)
+
+ double precision l1xi,l2xi,l3xi
+ double precision l1eta,l2eta,l3eta
+ double precision l1gamma,l2gamma,l3gamma
+ double precision l1pxi,l2pxi,l3pxi
+ double precision l1peta,l2peta,l3peta
+ double precision l1pgamma,l2pgamma,l3pgamma
+
+ double precision xxi,yxi,zxi
+ double precision xeta,yeta,zeta
+ double precision xgamma,ygamma,zgamma
+
+ integer ia
+
+! recompute jacobian for any given (xi,eta,gamma) point
+! not necessarily a GLL point
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) stop 'elements should have 27 control nodes'
+
+ l1xi=HALF*xi*(xi-ONE)
+ l2xi=ONE-xi**2
+ l3xi=HALF*xi*(xi+ONE)
+
+ l1pxi=xi-HALF
+ l2pxi=-TWO*xi
+ l3pxi=xi+HALF
+
+ l1eta=HALF*eta*(eta-ONE)
+ l2eta=ONE-eta**2
+ l3eta=HALF*eta*(eta+ONE)
+
+ l1peta=eta-HALF
+ l2peta=-TWO*eta
+ l3peta=eta+HALF
+
+ l1gamma=HALF*gamma*(gamma-ONE)
+ l2gamma=ONE-gamma**2
+ l3gamma=HALF*gamma*(gamma+ONE)
+
+ l1pgamma=gamma-HALF
+ l2pgamma=-TWO*gamma
+ l3pgamma=gamma+HALF
+
+! corner nodes
+
+ shape3D(1)=l1xi*l1eta*l1gamma
+ shape3D(2)=l3xi*l1eta*l1gamma
+ shape3D(3)=l3xi*l3eta*l1gamma
+ shape3D(4)=l1xi*l3eta*l1gamma
+ shape3D(5)=l1xi*l1eta*l3gamma
+ shape3D(6)=l3xi*l1eta*l3gamma
+ shape3D(7)=l3xi*l3eta*l3gamma
+ shape3D(8)=l1xi*l3eta*l3gamma
+
+ dershape3D(1,1)=l1pxi*l1eta*l1gamma
+ dershape3D(1,2)=l3pxi*l1eta*l1gamma
+ dershape3D(1,3)=l3pxi*l3eta*l1gamma
+ dershape3D(1,4)=l1pxi*l3eta*l1gamma
+ dershape3D(1,5)=l1pxi*l1eta*l3gamma
+ dershape3D(1,6)=l3pxi*l1eta*l3gamma
+ dershape3D(1,7)=l3pxi*l3eta*l3gamma
+ dershape3D(1,8)=l1pxi*l3eta*l3gamma
+
+ dershape3D(2,1)=l1xi*l1peta*l1gamma
+ dershape3D(2,2)=l3xi*l1peta*l1gamma
+ dershape3D(2,3)=l3xi*l3peta*l1gamma
+ dershape3D(2,4)=l1xi*l3peta*l1gamma
+ dershape3D(2,5)=l1xi*l1peta*l3gamma
+ dershape3D(2,6)=l3xi*l1peta*l3gamma
+ dershape3D(2,7)=l3xi*l3peta*l3gamma
+ dershape3D(2,8)=l1xi*l3peta*l3gamma
+
+ dershape3D(3,1)=l1xi*l1eta*l1pgamma
+ dershape3D(3,2)=l3xi*l1eta*l1pgamma
+ dershape3D(3,3)=l3xi*l3eta*l1pgamma
+ dershape3D(3,4)=l1xi*l3eta*l1pgamma
+ dershape3D(3,5)=l1xi*l1eta*l3pgamma
+ dershape3D(3,6)=l3xi*l1eta*l3pgamma
+ dershape3D(3,7)=l3xi*l3eta*l3pgamma
+ dershape3D(3,8)=l1xi*l3eta*l3pgamma
+
+! midside nodes
+
+ shape3D(9)=l2xi*l1eta*l1gamma
+ shape3D(10)=l3xi*l2eta*l1gamma
+ shape3D(11)=l2xi*l3eta*l1gamma
+ shape3D(12)=l1xi*l2eta*l1gamma
+ shape3D(13)=l1xi*l1eta*l2gamma
+ shape3D(14)=l3xi*l1eta*l2gamma
+ shape3D(15)=l3xi*l3eta*l2gamma
+ shape3D(16)=l1xi*l3eta*l2gamma
+ shape3D(17)=l2xi*l1eta*l3gamma
+ shape3D(18)=l3xi*l2eta*l3gamma
+ shape3D(19)=l2xi*l3eta*l3gamma
+ shape3D(20)=l1xi*l2eta*l3gamma
+
+ dershape3D(1,9)=l2pxi*l1eta*l1gamma
+ dershape3D(1,10)=l3pxi*l2eta*l1gamma
+ dershape3D(1,11)=l2pxi*l3eta*l1gamma
+ dershape3D(1,12)=l1pxi*l2eta*l1gamma
+ dershape3D(1,13)=l1pxi*l1eta*l2gamma
+ dershape3D(1,14)=l3pxi*l1eta*l2gamma
+ dershape3D(1,15)=l3pxi*l3eta*l2gamma
+ dershape3D(1,16)=l1pxi*l3eta*l2gamma
+ dershape3D(1,17)=l2pxi*l1eta*l3gamma
+ dershape3D(1,18)=l3pxi*l2eta*l3gamma
+ dershape3D(1,19)=l2pxi*l3eta*l3gamma
+ dershape3D(1,20)=l1pxi*l2eta*l3gamma
+
+ dershape3D(2,9)=l2xi*l1peta*l1gamma
+ dershape3D(2,10)=l3xi*l2peta*l1gamma
+ dershape3D(2,11)=l2xi*l3peta*l1gamma
+ dershape3D(2,12)=l1xi*l2peta*l1gamma
+ dershape3D(2,13)=l1xi*l1peta*l2gamma
+ dershape3D(2,14)=l3xi*l1peta*l2gamma
+ dershape3D(2,15)=l3xi*l3peta*l2gamma
+ dershape3D(2,16)=l1xi*l3peta*l2gamma
+ dershape3D(2,17)=l2xi*l1peta*l3gamma
+ dershape3D(2,18)=l3xi*l2peta*l3gamma
+ dershape3D(2,19)=l2xi*l3peta*l3gamma
+ dershape3D(2,20)=l1xi*l2peta*l3gamma
+
+ dershape3D(3,9)=l2xi*l1eta*l1pgamma
+ dershape3D(3,10)=l3xi*l2eta*l1pgamma
+ dershape3D(3,11)=l2xi*l3eta*l1pgamma
+ dershape3D(3,12)=l1xi*l2eta*l1pgamma
+ dershape3D(3,13)=l1xi*l1eta*l2pgamma
+ dershape3D(3,14)=l3xi*l1eta*l2pgamma
+ dershape3D(3,15)=l3xi*l3eta*l2pgamma
+ dershape3D(3,16)=l1xi*l3eta*l2pgamma
+ dershape3D(3,17)=l2xi*l1eta*l3pgamma
+ dershape3D(3,18)=l3xi*l2eta*l3pgamma
+ dershape3D(3,19)=l2xi*l3eta*l3pgamma
+ dershape3D(3,20)=l1xi*l2eta*l3pgamma
+
+! side center nodes
+
+ shape3D(21)=l2xi*l2eta*l1gamma
+ shape3D(22)=l2xi*l1eta*l2gamma
+ shape3D(23)=l3xi*l2eta*l2gamma
+ shape3D(24)=l2xi*l3eta*l2gamma
+ shape3D(25)=l1xi*l2eta*l2gamma
+ shape3D(26)=l2xi*l2eta*l3gamma
+
+ dershape3D(1,21)=l2pxi*l2eta*l1gamma
+ dershape3D(1,22)=l2pxi*l1eta*l2gamma
+ dershape3D(1,23)=l3pxi*l2eta*l2gamma
+ dershape3D(1,24)=l2pxi*l3eta*l2gamma
+ dershape3D(1,25)=l1pxi*l2eta*l2gamma
+ dershape3D(1,26)=l2pxi*l2eta*l3gamma
+
+ dershape3D(2,21)=l2xi*l2peta*l1gamma
+ dershape3D(2,22)=l2xi*l1peta*l2gamma
+ dershape3D(2,23)=l3xi*l2peta*l2gamma
+ dershape3D(2,24)=l2xi*l3peta*l2gamma
+ dershape3D(2,25)=l1xi*l2peta*l2gamma
+ dershape3D(2,26)=l2xi*l2peta*l3gamma
+
+ dershape3D(3,21)=l2xi*l2eta*l1pgamma
+ dershape3D(3,22)=l2xi*l1eta*l2pgamma
+ dershape3D(3,23)=l3xi*l2eta*l2pgamma
+ dershape3D(3,24)=l2xi*l3eta*l2pgamma
+ dershape3D(3,25)=l1xi*l2eta*l2pgamma
+ dershape3D(3,26)=l2xi*l2eta*l3pgamma
+
+! center node
+
+ shape3D(27)=l2xi*l2eta*l2gamma
+
+ dershape3D(1,27)=l2pxi*l2eta*l2gamma
+ dershape3D(2,27)=l2xi*l2peta*l2gamma
+ dershape3D(3,27)=l2xi*l2eta*l2pgamma
+
+! compute coordinates and jacobian matrix
+ x=ZERO
+ y=ZERO
+ z=ZERO
+ xxi=ZERO
+ xeta=ZERO
+ xgamma=ZERO
+ yxi=ZERO
+ yeta=ZERO
+ ygamma=ZERO
+ zxi=ZERO
+ zeta=ZERO
+ zgamma=ZERO
+
+ do ia=1,NGNOD
+ x=x+shape3D(ia)*xelm(ia)
+ y=y+shape3D(ia)*yelm(ia)
+ z=z+shape3D(ia)*zelm(ia)
+
+ xxi=xxi+dershape3D(1,ia)*xelm(ia)
+ xeta=xeta+dershape3D(2,ia)*xelm(ia)
+ xgamma=xgamma+dershape3D(3,ia)*xelm(ia)
+ yxi=yxi+dershape3D(1,ia)*yelm(ia)
+ yeta=yeta+dershape3D(2,ia)*yelm(ia)
+ ygamma=ygamma+dershape3D(3,ia)*yelm(ia)
+ zxi=zxi+dershape3D(1,ia)*zelm(ia)
+ zeta=zeta+dershape3D(2,ia)*zelm(ia)
+ zgamma=zgamma+dershape3D(3,ia)*zelm(ia)
+ enddo
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
+
+ if(jacobian <= ZERO) stop '3D Jacobian undefined'
+
+! invert the relation (Fletcher p. 50 vol. 2)
+ xix=(yeta*zgamma-ygamma*zeta)/jacobian
+ xiy=(xgamma*zeta-xeta*zgamma)/jacobian
+ xiz=(xeta*ygamma-xgamma*yeta)/jacobian
+ etax=(ygamma*zxi-yxi*zgamma)/jacobian
+ etay=(xxi*zgamma-xgamma*zxi)/jacobian
+ etaz=(xgamma*yxi-xxi*ygamma)/jacobian
+ gammax=(yxi*zeta-yeta*zxi)/jacobian
+ gammay=(xeta*zxi-xxi*zeta)/jacobian
+ gammaz=(xxi*yeta-xeta*yxi)/jacobian
+
+ end subroutine recompute_jacobian
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/recompute_missing_arrays.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_missing_arrays.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/recompute_missing_arrays.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/recompute_missing_arrays.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,202 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+!! DK DK added this for merged version
+ subroutine recompute_missing_arrays(myrank, &
+ xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore, &
+ xelm_store,yelm_store,zelm_store,ibool,nspec,nglob)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,nglob,myrank
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(NGNOD,nspec) :: xelm_store,yelm_store,zelm_store
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+ integer i,j,k,ia,ispec
+
+ double precision xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
+ double precision xmesh,ymesh,zmesh
+ double precision xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ double precision jacobian
+
+! Gauss-Lobatto-Legendre points and weights of integration
+ double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
+
+! 3D shape functions and their derivatives
+ double precision, dimension(:,:,:,:), allocatable :: shape3D
+ double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
+
+! Gauss-Lobatto-Legendre points of integration
+ allocate(xigll(NGLLX))
+ allocate(yigll(NGLLY))
+ allocate(zigll(NGLLZ))
+
+! Gauss-Lobatto-Legendre weights of integration
+ allocate(wxgll(NGLLX))
+ allocate(wygll(NGLLY))
+ allocate(wzgll(NGLLZ))
+
+! 3D shape functions and their derivatives
+ allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ))
+ allocate(dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ))
+
+! 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)
+
+ do ispec = 1,nspec
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ xxi = ZERO
+ xeta = ZERO
+ xgamma = ZERO
+ yxi = ZERO
+ yeta = ZERO
+ ygamma = ZERO
+ zxi = ZERO
+ zeta = ZERO
+ zgamma = ZERO
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+
+ do ia=1,NGNOD
+ if(CUSTOM_REAL == SIZE_REAL) then
+ xxi = xxi + dershape3D(1,ia,i,j,k)*dble(xelm_store(ia,ispec))
+ xeta = xeta + dershape3D(2,ia,i,j,k)*dble(xelm_store(ia,ispec))
+ xgamma = xgamma + dershape3D(3,ia,i,j,k)*dble(xelm_store(ia,ispec))
+ yxi = yxi + dershape3D(1,ia,i,j,k)*dble(yelm_store(ia,ispec))
+ yeta = yeta + dershape3D(2,ia,i,j,k)*dble(yelm_store(ia,ispec))
+ ygamma = ygamma + dershape3D(3,ia,i,j,k)*dble(yelm_store(ia,ispec))
+ zxi = zxi + dershape3D(1,ia,i,j,k)*dble(zelm_store(ia,ispec))
+ zeta = zeta + dershape3D(2,ia,i,j,k)*dble(zelm_store(ia,ispec))
+ zgamma = zgamma + dershape3D(3,ia,i,j,k)*dble(zelm_store(ia,ispec))
+ xmesh = xmesh + shape3D(ia,i,j,k)*dble(xelm_store(ia,ispec))
+ ymesh = ymesh + shape3D(ia,i,j,k)*dble(yelm_store(ia,ispec))
+ zmesh = zmesh + shape3D(ia,i,j,k)*dble(zelm_store(ia,ispec))
+ else
+ xxi = xxi + dershape3D(1,ia,i,j,k)*xelm_store(ia,ispec)
+ xeta = xeta + dershape3D(2,ia,i,j,k)*xelm_store(ia,ispec)
+ xgamma = xgamma + dershape3D(3,ia,i,j,k)*xelm_store(ia,ispec)
+ yxi = yxi + dershape3D(1,ia,i,j,k)*yelm_store(ia,ispec)
+ yeta = yeta + dershape3D(2,ia,i,j,k)*yelm_store(ia,ispec)
+ ygamma = ygamma + dershape3D(3,ia,i,j,k)*yelm_store(ia,ispec)
+ zxi = zxi + dershape3D(1,ia,i,j,k)*zelm_store(ia,ispec)
+ zeta = zeta + dershape3D(2,ia,i,j,k)*zelm_store(ia,ispec)
+ zgamma = zgamma + dershape3D(3,ia,i,j,k)*zelm_store(ia,ispec)
+ xmesh = xmesh + shape3D(ia,i,j,k)*xelm_store(ia,ispec)
+ ymesh = ymesh + shape3D(ia,i,j,k)*yelm_store(ia,ispec)
+ zmesh = zmesh + shape3D(ia,i,j,k)*zelm_store(ia,ispec)
+ endif
+ enddo
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+ xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
+
+ if(jacobian <= ZERO) call exit_MPI(myrank,'3D Jacobian undefined when recomputing missing arrays')
+
+! invert the relation (Fletcher p. 50 vol. 2)
+ xix = (yeta*zgamma-ygamma*zeta) / jacobian
+ xiy = (xgamma*zeta-xeta*zgamma) / jacobian
+ xiz = (xeta*ygamma-xgamma*yeta) / jacobian
+ etax = (ygamma*zxi-yxi*zgamma) / jacobian
+ etay = (xxi*zgamma-xgamma*zxi) / jacobian
+ etaz = (xgamma*yxi-xxi*ygamma) / jacobian
+ gammax = (yxi*zeta-yeta*zxi) / jacobian
+ gammay = (xeta*zxi-xxi*zeta) / jacobian
+ gammaz = (xxi*yeta-xeta*yxi) / jacobian
+
+! save the derivatives and the jacobian
+! store mesh coordinates
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ xixstore(i,j,k,ispec) = sngl(xix)
+ xiystore(i,j,k,ispec) = sngl(xiy)
+ xizstore(i,j,k,ispec) = sngl(xiz)
+ etaxstore(i,j,k,ispec) = sngl(etax)
+ etaystore(i,j,k,ispec) = sngl(etay)
+ etazstore(i,j,k,ispec) = sngl(etaz)
+ gammaxstore(i,j,k,ispec) = sngl(gammax)
+ gammaystore(i,j,k,ispec) = sngl(gammay)
+ gammazstore(i,j,k,ispec) = sngl(gammaz)
+
+ xstore(ibool(i,j,k,ispec)) = sngl(xmesh)
+ ystore(ibool(i,j,k,ispec)) = sngl(ymesh)
+ zstore(ibool(i,j,k,ispec)) = sngl(zmesh)
+ else
+ xixstore(i,j,k,ispec) = xix
+ xiystore(i,j,k,ispec) = xiy
+ xizstore(i,j,k,ispec) = xiz
+ etaxstore(i,j,k,ispec) = etax
+ etaystore(i,j,k,ispec) = etay
+ etazstore(i,j,k,ispec) = etaz
+ gammaxstore(i,j,k,ispec) = gammax
+ gammaystore(i,j,k,ispec) = gammay
+ gammazstore(i,j,k,ispec) = gammaz
+
+ xstore(ibool(i,j,k,ispec)) = xmesh
+ ystore(ibool(i,j,k,ispec)) = ymesh
+ zstore(ibool(i,j,k,ispec)) = zmesh
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+ deallocate(xigll,yigll,zigll)
+ deallocate(wxgll,wygll,wzgll)
+ deallocate(shape3D,dershape3D)
+
+ end subroutine recompute_missing_arrays
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/reduce.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/reduce.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/reduce.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/reduce.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,84 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 reduce(theta,phi)
+
+! bring theta between 0 and PI, and phi between 0 and 2*PI
+
+ implicit none
+
+ include "constants.h"
+
+ double precision theta,phi
+
+ integer i
+ double precision th,ph
+
+ th=theta
+ ph=phi
+ i=abs(int(ph/TWO_PI))
+ if(ph<ZERO) then
+ ph=ph+(i+1)*TWO_PI
+ else
+ if(ph>TWO_PI) ph=ph-i*TWO_PI
+ endif
+ phi=ph
+ if(th<ZERO .or. th>PI) then
+ i=int(th/PI)
+ if(th>ZERO) then
+ if(mod(i,2) /= 0) then
+ th=(i+1)*PI-th
+ if(ph<PI) then
+ ph=ph+PI
+ else
+ ph=ph-PI
+ endif
+ else
+ th=th-i*PI
+ endif
+ else
+ if(mod(i,2) == 0) then
+ th=-th+i*PI
+ if(ph<PI) then
+ ph=ph+PI
+ else
+ ph=ph-PI
+ endif
+ else
+ th=th-i*PI
+ endif
+ endif
+ theta=th
+ phi=ph
+ endif
+
+ if(theta<ZERO .or. theta>PI) stop 'theta out of range in reduce'
+
+ if(phi<ZERO .or. phi>TWO_PI) stop 'phi out of range in reduce'
+
+ end subroutine reduce
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/rthetaphi_xyz.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/rthetaphi_xyz.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/rthetaphi_xyz.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/rthetaphi_xyz.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,119 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 xyz_2_rthetaphi(x,y,z,r,theta,phi)
+
+! convert x y z to r theta phi, single precision call
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) x,y,z,r,theta,phi
+ double precision xmesh,ymesh,zmesh
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+ xmesh = dble(x)
+ ymesh = dble(y)
+ zmesh = dble(z)
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+ theta = sngl(datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh))
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+ phi = sngl(datan2(ymesh,xmesh))
+
+ r = sngl(dsqrt(xmesh**2 + ymesh**2 + zmesh**2))
+
+ else
+
+ xmesh = x
+ ymesh = y
+ zmesh = z
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+ theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+ phi = datan2(ymesh,xmesh)
+
+ r = dsqrt(xmesh**2 + ymesh**2 + zmesh**2)
+
+ endif
+
+ end subroutine xyz_2_rthetaphi
+
+!-------------------------------------------------------------
+
+ subroutine xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+
+! convert x y z to r theta phi, double precision call
+
+ implicit none
+
+ include "constants.h"
+
+ double precision x,y,z,r,theta,phi
+ double precision xmesh,ymesh,zmesh
+
+ xmesh = x
+ ymesh = y
+ zmesh = z
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+ theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+ phi = datan2(ymesh,xmesh)
+
+ r = dsqrt(xmesh**2 + ymesh**2 + zmesh**2)
+
+ end subroutine xyz_2_rthetaphi_dble
+
+!-------------------------------------------------------------
+
+ subroutine rthetaphi_2_xyz(x,y,z,r,theta,phi)
+
+! convert r theta phi to x y z
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) x,y,z,r,theta,phi
+
+ x = r * sin(theta) * cos(phi)
+ y = r * sin(theta) * sin(phi)
+ z = r * cos(theta)
+
+ end subroutine rthetaphi_2_xyz
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/s362ani.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/s362ani.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/s362ani.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/s362ani.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,1784 @@
+
+ subroutine evradker(depth,string,nker,vercof,dvercof,ierror)
+
+ implicit none
+
+ integer :: nker,ierror
+
+ real(kind=4) :: chebyshev(100)
+ real(kind=4) :: chebyshev2(100)
+ real(kind=4) :: vercof(nker)
+ real(kind=4) :: dvercof(nker)
+ real(kind=4) :: splpts(100)
+
+ character(len=80) string
+
+ logical upper,upper_650
+ logical lower,lower_650
+
+ real(kind=4), parameter :: r0=6371.
+ real(kind=4), parameter :: rmoho=6371.0-24.4
+ real(kind=4), parameter :: r670=6371.-670.
+ real(kind=4), parameter :: r650=6371.-650.
+ real(kind=4), parameter :: rcmb=3480.0
+
+ integer :: i,nspl,nskip,nlower,nupper,iker,lstr
+
+ real(kind=4) :: u,u2,ddep,radius2,radius,depth
+
+ ierror=0
+ lstr=len_trim(string)
+
+ radius=r0-depth
+ ddep=0.1
+ radius2=r0-depth+ddep
+ upper=.false.
+ lower=.false.
+ if(radius > rcmb.and.radius < r670) then
+ lower=.true.
+ else if(radius >= r670.and.radius < rmoho) then
+ upper=.true.
+ endif
+ upper_650=.false.
+ lower_650=.false.
+ if(radius > rcmb.and.radius < r650) then
+ lower_650=.true.
+ else if(radius >= r650.and.radius < rmoho) then
+ upper_650=.true.
+ endif
+ do iker=1,nker
+ vercof(iker)=0.
+ dvercof(iker)=0.
+ enddo
+
+ if(string(1:16) == 'WDC+SPC_U4L8CHEB') then
+ nupper=5
+ nlower=9
+ nskip=2
+ if(upper) then
+ u=(radius+radius-rmoho-r670)/(rmoho-r670)
+ u2=(radius2+radius2-rmoho-r670)/(rmoho-r670)
+! write(6,"('upper mantle:',2f10.3)") u,u2
+ call chebyfun(u,13,chebyshev)
+ do i=1+nskip,nskip+nupper
+ vercof(i)=chebyshev(i-nskip)
+ enddo
+ call chebyfun(u2,13,chebyshev2)
+ do i=1+nskip,nskip+nupper
+ dvercof(i)=(chebyshev2(i-nskip)-chebyshev(i-nskip))/ddep
+ enddo
+ else if(lower) then
+ u=(radius+radius-r670-rcmb)/(r670-rcmb)
+ u2=(radius2+radius2-r670-rcmb)/(r670-rcmb)
+! write(6,"('lower mantle:',2f10.3)") u,u2
+ call chebyfun(u,13,chebyshev)
+ do i=1+nskip+nupper,nskip+nupper+nlower
+ vercof(i)=chebyshev(i-nskip-nupper)
+ enddo
+ call chebyfun(u2,13,chebyshev2)
+ do i=1+nskip+nupper,nskip+nupper+nlower
+ dvercof(i)=(chebyshev2(i-nskip-nupper)- &
+ chebyshev(i-nskip-nupper))/ddep
+ enddo
+ endif
+ else if(string(1:13) == 'WDC+SHSVWM20A') then
+ nspl=20
+ splpts(1)=0.
+ splpts(2)=50.
+ splpts(3)=100.
+ splpts(4)=150.
+ splpts(5)=200.
+ splpts(6)=250.
+ splpts(7)=300.
+ splpts(8)=400.
+ splpts(9)=500.
+ splpts(10)=600.
+ splpts(11)=700.
+ splpts(12)=850.
+ splpts(13)=1050.
+ splpts(14)=1300.
+ splpts(15)=1600.
+ splpts(16)=1900.
+ splpts(17)=2200.
+ splpts(18)=2500.
+ splpts(19)=2700.
+ splpts(20)=2891.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=22,27
+ vercof(i)=vercof(i-20)
+ dvercof(i)=dvercof(i-20)
+ enddo
+ vercof(1)=1.
+ else if(string(1:16) == 'WDC+XBS_362_U6L8') then
+ if(upper) then
+ nspl=6
+ splpts(1)=24.4
+ splpts(2)=100.
+ splpts(3)=225.
+ splpts(4)=350.
+ splpts(5)=500.
+ splpts(6)=670.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ else if(lower) then
+ nspl=8
+ splpts(1)=670.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+ endif
+ vercof(1)=1.
+! vercof(16)=1.
+! vercof(17)=1.
+! else if(string(1:21) == 'WDC+ANI_362_U6L8_TOPO') then
+! if(upper) then
+! nspl=6
+! splpts(1)=24.4
+! splpts(2)=100.
+! splpts(3)=225.
+! splpts(4)=350.
+! splpts(5)=500.
+! splpts(6)=670.
+! call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+! do i=16,21
+! vercof(i)=vercof(i-14)
+! dvercof(i)=dvercof(i-14)
+! enddo
+! else if(lower) then
+! nspl=8
+! splpts(1)=670.
+! splpts(2)=820.
+! splpts(3)=1320.
+! splpts(4)=1820.
+! splpts(5)=2320.
+! splpts(6)=2550.
+! splpts(7)=2791.
+! splpts(8)=2891.
+! call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+! endif
+! vercof(1)=1.
+! vercof(22)=1.
+! vercof(23)=1.
+! vercof(24)=1.
+! vercof(25)=1.
+ else if( &
+ (string(1:lstr) == 'WDC+ANI_362_U6L8'.and.lstr == 16) &
+ .or. &
+ (string(1:lstr) == 'WDC+ANI_362_U6L8_TOPO'.and.lstr == 21) &
+ ) then
+ if(upper) then
+ nspl=6
+ splpts(1)=24.4
+ splpts(2)=100.
+ splpts(3)=225.
+ splpts(4)=350.
+ splpts(5)=500.
+ splpts(6)=670.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=16,21
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ else if(lower) then
+ nspl=8
+ splpts(1)=670.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+ endif
+ vercof(1)=1.
+ vercof(22)=1.
+ vercof(23)=1.
+ else if(string(1:lstr) == 'WDC+WM_362_U6L8'.and.lstr == 15) then
+ if(upper) then
+ nspl=6
+ splpts(1)=24.4
+ splpts(2)=100.
+ splpts(3)=225.
+ splpts(4)=350.
+ splpts(5)=500.
+ splpts(6)=670.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=16,21
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ else if(lower) then
+ nspl=8
+ splpts(1)=670.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+ do i=22,29
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(30)=1.
+ vercof(31)=1.
+ vercof(32)=1.
+ else if( &
+ (string(1:lstr) == 'WDC+ANI_362_U6L8_650'.and.lstr == 20) &
+ .or. &
+ (string(1:lstr) == 'WDC+ANI_362_U6L8_TOPO_650'.and.lstr == 25) &
+ ) then
+ if(upper_650) then
+ nspl=6
+ splpts(1)=24.4
+ splpts(2)=100.
+ splpts(3)=225.
+ splpts(4)=350.
+ splpts(5)=500.
+ splpts(6)=650.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=16,21
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+ endif
+ vercof(1)=1.
+ vercof(22)=1.
+ vercof(23)=1.
+ else if(string(1:lstr) == 'WDC+WM_362_U6L8_650' &
+ .and.lstr == 19) then
+ if(upper_650) then
+ nspl=6
+ splpts(1)=24.4
+ splpts(2)=100.
+ splpts(3)=225.
+ splpts(4)=350.
+ splpts(5)=500.
+ splpts(6)=650.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=16,21
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+ do i=22,29
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(30)=1.
+ vercof(31)=1.
+ vercof(32)=1.
+ else if(string(1:lstr) == 'WDC+U8L8_650'.and.lstr == 12) then
+ if(upper_650) then
+ nspl=8
+ splpts(1)=24.4
+ splpts(2)=75.
+ splpts(3)=150.
+ splpts(4)=225.
+ splpts(5)=300.
+ splpts(6)=410.
+ splpts(7)=530.
+ splpts(8)=650.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=18,25
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
+ do i=26,33
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(34)=1.
+ vercof(35)=1.
+ vercof(36)=1.
+ else if(string(1:lstr) == 'WDC+U8L8_670'.and.lstr == 12) then
+ if(upper) then
+ nspl=8
+ splpts(1)=24.4
+ splpts(2)=75.
+ splpts(3)=150.
+ splpts(4)=225.
+ splpts(5)=300.
+ splpts(6)=410.
+ splpts(7)=530.
+ splpts(8)=670.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=18,25
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ else if(lower) then
+ nspl=8
+ splpts(1)=670.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
+ do i=26,33
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(34)=1.
+ vercof(35)=1.
+ vercof(36)=1.
+ else if( &
+ (string(1:lstr) == 'WDC+U8L8_I1D_650'.and.lstr == 16) &
+ .or. &
+ (string(1:lstr) == 'WDC+U8L8_I3D_650'.and.lstr == 16) &
+ ) then
+ if(upper_650) then
+ nspl=8
+ splpts(1)=24.4
+ splpts(2)=75.
+ splpts(3)=150.
+ splpts(4)=225.
+ splpts(5)=300.
+ splpts(6)=410.
+ splpts(7)=530.
+ splpts(8)=650.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=18,25
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ do i=37,40
+ vercof(i)=vercof(i-35)
+ dvercof(i)=dvercof(i-35)
+ enddo
+ do i=41,44
+ vercof(i)=vercof(i-39)
+ dvercof(i)=dvercof(i-39)
+ enddo
+ do i=45,48
+ vercof(i)=vercof(i-43)
+ dvercof(i)=dvercof(i-43)
+ enddo
+ do i=49,52
+ vercof(i)=vercof(i-47)
+ dvercof(i)=dvercof(i-47)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
+ do i=26,33
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(34)=1.
+ vercof(35)=1.
+ vercof(36)=1.
+ else if((string(1:lstr) == 'WDC+I1D_650'.and.lstr == 11).or. &
+ (string(1:lstr) == 'WDC+I3D_650'.and.lstr == 11)) then
+ if(upper_650) then
+ nspl=8
+ splpts(1)=24.4
+ splpts(2)=75.
+ splpts(3)=150.
+ splpts(4)=225.
+ splpts(5)=300.
+ splpts(6)=410.
+ splpts(7)=530.
+ splpts(8)=650.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=18,25
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ do i=37,44
+ vercof(i)=vercof(i-35)
+ dvercof(i)=dvercof(i-35)
+ enddo
+ do i=53,60
+ vercof(i)=vercof(i-51)
+ dvercof(i)=dvercof(i-51)
+ enddo
+ do i=69,76
+ vercof(i)=vercof(i-67)
+ dvercof(i)=dvercof(i-67)
+ enddo
+ do i=85,92
+ vercof(i)=vercof(i-83)
+ dvercof(i)=dvercof(i-83)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
+ do i=26,33
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ do i=45,52
+ vercof(i)=vercof(i-35)
+ dvercof(i)=dvercof(i-35)
+ enddo
+ do i=61,68
+ vercof(i)=vercof(i-51)
+ dvercof(i)=dvercof(i-51)
+ enddo
+ do i=77,84
+ vercof(i)=vercof(i-67)
+ dvercof(i)=dvercof(i-67)
+ enddo
+ do i=93,100
+ vercof(i)=vercof(i-83)
+ dvercof(i)=dvercof(i-83)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(34)=1.
+ vercof(35)=1.
+ vercof(36)=1.
+ else if(string(1:lstr) == 'V16A4_V7A4'.and.lstr == 10) then
+ if(upper_650) then
+ nspl=8
+ splpts(1)=24.4
+ splpts(2)=75.
+ splpts(3)=150.
+ splpts(4)=225.
+ splpts(5)=300.
+ splpts(6)=410.
+ splpts(7)=530.
+ splpts(8)=650.
+ call vbspl(depth,nspl,splpts,vercof(1),dvercof(1))
+ do i=17,20
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ do i=23,29
+ vercof(i)=vercof(i-22)
+ dvercof(i)=dvercof(i-22)
+ enddo
+ do i=30,33
+ vercof(i)=vercof(i-29)
+ dvercof(i)=dvercof(i-29)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(9),dvercof(9))
+ endif
+ vercof(21)=1.
+ vercof(22)=1.
+ else
+ write(6,"('problem 4')")
+ write(6,"(a)")string(1:len_trim(string))
+ stop
+ endif
+
+ end subroutine evradker
+
+! ---
+
+ subroutine chebyfun(u,kmax,f)
+
+ implicit none
+
+ integer :: kmax
+
+ real(kind=4) :: chebycoeff(0:13),f(0:kmax),u
+
+ integer :: k
+
+ real(kind=4) :: twou
+
+ data chebycoeff / &
+ 0.70710678118655,1.2247448713916,1.0350983390135,1.0145993123918, &
+ 1.00803225754840,1.0050890913907,1.0035149493262,1.0025740068320, &
+ 1.00196657023780,1.0015515913133,1.0012554932754,1.0010368069141, &
+ 1.00087070107920,1.0007415648034 /
+
+ if(kmax > 13)then
+ write(*,"(' kmax exceeds the limit in chebyfun')")
+ stop
+ endif
+
+ f(0)=1.0
+ f(1)=u
+ twou=2.0*u
+
+ do k=2,kmax
+ f(k) = twou*f(k-1)-f(k-2)
+ enddo
+
+ do k=0,kmax
+ f(k)=f(k)*chebycoeff(k)
+ enddo
+
+ end subroutine chebyfun
+
+
+ subroutine gt3dmodl(lu,targetfile, &
+ maxhpa,maxker,maxcoe, &
+ numhpa,numker,numcoe,lmxhpa, &
+ ihpakern,itypehpa,coe, &
+ itpspl,xlatspl,xlonspl,radispl, &
+ numvar,ivarkern,varstr, &
+ refmdl,kerstr,hsplfl,dskker,ierror)
+
+ implicit none
+
+ integer, parameter :: mxhpar=2
+ integer, parameter :: mxkern=200
+ integer, parameter :: mxcoef=2000
+
+ character(len=80) refmodel
+ character(len=80) kernstri
+ character(len=40) desckern(mxkern)
+ character(len=80) hsplfile(mxhpar)
+
+ integer ihorpar(mxkern)
+ integer ityphpar(mxhpar)
+ integer ixlspl(mxcoef,mxhpar)
+ integer lmaxhor(mxhpar)
+ integer ncoefhor(mxhpar)
+
+ real(kind=4) coef(mxcoef,mxkern)
+ real(kind=4) xlaspl(mxcoef,mxhpar)
+ real(kind=4) xlospl(mxcoef,mxhpar)
+ real(kind=4) xraspl(mxcoef,mxhpar)
+
+ character(len=128) targetfile
+
+ integer numhpa,numker,maxhpa,maxker,maxcoe
+
+ integer numcoe(maxhpa)
+ integer lmxhpa(maxhpa)
+ integer ihpakern(maxker)
+ integer itypehpa(maxhpa)
+ integer itpspl(maxcoe,maxhpa)
+ integer ivarkern(maxker)
+
+ real(kind=4) coe(maxcoe,maxker)
+ real(kind=4) xlatspl(maxcoe,maxhpa)
+ real(kind=4) xlonspl(maxcoe,maxhpa)
+ real(kind=4) radispl(maxcoe,maxhpa)
+
+ character(len=80) refmdl
+ character(len=80) kerstr
+ character(len=80) hsplfl(maxhpa)
+ character(len=40) dskker(maxker)
+ character(len=40) string
+ character(len=40) varstr(maxker)
+
+ integer numvar,ierror,lu,nhorpar,nmodkern,i,j,lstr,k
+
+ ierror=0
+ call rd3dmodl(lu,targetfile,ierror, &
+ nmodkern,nhorpar,ityphpar, &
+ ihorpar,lmaxhor,ncoefhor, &
+ xlaspl,xlospl,xraspl,ixlspl,coef, &
+ hsplfile,refmodel,kernstri,desckern)
+
+ if(nhorpar <= maxhpa) then
+ numhpa=nhorpar
+ else
+ ierror=ierror+1
+ endif
+
+ if(nmodkern <= maxker) then
+ numker=nmodkern
+ else
+ ierror=ierror+1
+ endif
+
+ do i=1,nmodkern
+ ihpakern(i)=ihorpar(i)
+ dskker(i)=desckern(i)
+ do j=1,ncoefhor(ihpakern(i))
+ coe(j,i)=coef(j,i)
+! if(j == 1) then
+! write(6,"(e12.4)") coe(j,i)
+! endif
+ enddo
+ enddo
+
+ do i=1,nhorpar
+ numcoe(i)=ncoefhor(i)
+ lmxhpa(i)=lmaxhor(i)
+ itypehpa(i)=ityphpar(i)
+ if(itypehpa(i) == 2) then
+ do j=1,ncoefhor(i)
+ itpspl(j,i)=ixlspl(j,i)
+ xlatspl(j,i)=xlaspl(j,i)
+ xlonspl(j,i)=xlospl(j,i)
+ radispl(j,i)=xraspl(j,i)
+ enddo
+ endif
+ hsplfl(i)=hsplfile(i)
+ enddo
+
+ numvar=0
+ do i=1,nmodkern
+ string=dskker(i)
+ lstr=len_trim(string)
+ j=1
+ do while(string(j:j) /= ','.and.j < lstr)
+ j=j+1
+ enddo
+ ivarkern(i)=0
+ do k=1,numvar
+ if(string(1:j) == varstr(k)(1:j)) then
+ ivarkern(i)=k
+ endif
+ enddo
+ if(ivarkern(i) == 0) then
+ numvar=numvar+1
+ varstr(numvar)=string(1:j)
+ ivarkern(i)=numvar
+ endif
+ enddo
+
+ refmdl=refmodel
+ kerstr=kernstri
+
+ end subroutine gt3dmodl
+
+
+ subroutine rd3dmodl(lu,filename,ierror, &
+ nmodkern,nhorpar,ityphpar, &
+ ihorpar,lmaxhor,ncoefhor, &
+ xlaspl,xlospl,xraspl,ixlspl,coef, &
+ hsplfile,refmodel,kernstri,desckern)
+
+ implicit none
+
+ integer, parameter :: mxhpar=2
+ integer, parameter :: mxkern=200
+ integer, parameter :: mxcoef=2000
+
+ character(len=80) refmodel
+ character(len=80) kernstri
+ character(len=40) desckern(mxkern)
+ character(len=80) hsplfile(mxhpar)
+
+ integer ihorpar(mxkern)
+ integer ityphpar(mxhpar)
+ integer ixlspl(mxcoef,mxhpar)
+ integer lmaxhor(mxhpar)
+ integer ncoefhor(mxhpar)
+
+ real(kind=4) coef(mxcoef,mxkern)
+ real(kind=4) xlaspl(mxcoef,mxhpar)
+ real(kind=4) xlospl(mxcoef,mxhpar)
+ real(kind=4) xraspl(mxcoef,mxhpar)
+
+ character(len=128) filename
+
+ character(len=128) string
+ character(len=128) substr
+
+ integer :: lu,ierror
+
+ integer :: ncoef,i,ihor,ifst,ilst,ifst1,ios,lstr,nmodkern,idummy,nhorpar,lmax
+
+ open(lu,file=filename,iostat=ios)
+ if(ios /= 0) then
+ stop 'error opening 3-d model'
+ endif
+ do while (ios == 0)
+ read(lu,"(a)",iostat=ios) string
+ lstr=len_trim(string)
+ if(ios == 0) then
+ if(string(1:16) == 'REFERENCE MODEL:') then
+ substr=string(17:lstr)
+ ifst=1
+ ilst=len_trim(substr)
+ do while (substr(ifst:ifst) == ' '.and.ifst < ilst)
+ ifst=ifst+1
+ enddo
+ if(ilst-ifst <= 0) then
+ stop 'error reading model 1'
+ else
+ refmodel=substr(ifst:ilst)
+ endif
+ else if(string(1:11) == 'KERNEL SET:') then
+ substr=string(12:len_trim(string))
+ ifst=1
+ ilst=len_trim(substr)
+ do while (substr(ifst:ifst) == ' '.and.ifst < ilst)
+ ifst=ifst+1
+ enddo
+ if(ilst-ifst <= 0) then
+ stop 'error reading model 2'
+ else
+ kernstri=substr(ifst:ilst)
+ endif
+ else if(string(1:25) == 'RADIAL STRUCTURE KERNELS:') then
+ substr=string(26:len_trim(string))
+ read(substr,*,iostat=ierror) nmodkern
+ if(ierror /= 0) then
+ stop 'error reading model 3'
+ endif
+ else if(string(1:4) == 'DESC'.and.string(9:9) == ':') then
+ read(string(5:8),"(i4)") idummy
+ substr=string(10:len_trim(string))
+ ifst=1
+ ilst=len_trim(substr)
+ do while (substr(ifst:ifst) == ' '.and.ifst < ilst)
+ ifst=ifst+1
+ enddo
+ if(ilst-ifst <= 0) then
+ stop 'error reading model 4'
+ else
+ desckern(idummy)=substr(ifst:ilst)
+ endif
+ else if(string(1:29) == 'HORIZONTAL PARAMETERIZATIONS:') then
+ substr=string(30:len_trim(string))
+ read(substr,*,iostat=ierror) nhorpar
+ if(ierror /= 0) then
+ stop 'error reading model 5'
+ endif
+ else if(string(1:4) == 'HPAR'.and.string(9:9) == ':') then
+ read(string(5:8),"(i4)") idummy
+ ifst=10
+ ilst=len_trim(string)
+ do while (string(ifst:ifst) == ' '.and.ifst < ilst)
+ ifst=ifst+1
+ enddo
+ if(ilst-ifst <= 0) then
+ stop 'error reading model 6'
+ else if(string(ifst:ifst+19) == 'SPHERICAL HARMONICS,') then
+ substr=string(20+ifst:len_trim(string))
+ read(substr,*) lmax
+ ityphpar(idummy)=1
+ lmaxhor(idummy)=lmax
+ ncoefhor(idummy)=(lmax+1)**2
+ else if(string(ifst:ifst+17) == 'SPHERICAL SPLINES,') then
+ ifst1=ifst+18
+ ifst=len_trim(string)
+ ilst=len_trim(string)
+ do while(string(ifst:ifst) /= ',')
+ ifst=ifst-1
+ enddo
+ read(string(ifst+1:ilst),*) ncoef
+ substr=string(ifst1:ifst-1)
+ do while (string(ifst1:ifst1) == ' '.and.ifst1 < ifst)
+ ifst1=ifst1+1
+ enddo
+ hsplfile(idummy)=string(ifst1:ifst-1)
+ ityphpar(idummy)=2
+ lmaxhor(idummy)=0
+ ncoefhor(idummy)=ncoef
+ do i=1,ncoef
+ read(lu,*) ixlspl(i,idummy),xlaspl(i,idummy), &
+ xlospl(i,idummy),xraspl(i,idummy)
+ enddo
+ endif
+ else if(string(1:4) == 'STRU'.and.string(9:9) == ':') then
+ read(string(5:8),"(i4)") idummy
+ substr=string(10:len_trim(string))
+ read(substr,*) ihor
+ ihorpar(idummy)=ihor
+ ncoef=ncoefhor(ihor)
+ read(lu,"(6e12.4)") (coef(i,idummy),i=1,ncoef)
+ endif
+ endif
+ enddo
+ close(lu)
+
+ end subroutine rd3dmodl
+
+
+ subroutine 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)
+
+ implicit none
+
+ integer THREE_D_MODEL,THREE_D_MODEL_S362ANI
+ integer THREE_D_MODEL_S362WMANI
+ integer THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA
+
+ integer lu
+ character(len=128) modeldef
+ logical exists
+ integer numvar
+ integer ierror
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa
+ integer ihpa
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+ integer itpspl(maxcoe,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)
+
+ character(len=80) kerstr
+ character(len=80) refmdl
+ character(len=40) varstr(maxker)
+
+! -------------------------------------
+
+ lu=1 ! --- log unit: input 3-D model
+ if(THREE_D_MODEL == THREE_D_MODEL_S362ANI) then
+ modeldef='DATA/s362ani/S362ANI'
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362WMANI) then
+ modeldef='DATA/s362ani/S362WMANI'
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM) then
+ modeldef='DATA/s362ani/S362ANI_PREM'
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S29EA) then
+ modeldef='DATA/s362ani/S2.9EA'
+ else
+ stop 'unknown 3D model in read_model_s362ani'
+ endif
+ inquire(file=modeldef,exist=exists)
+ if(exists) then
+ call gt3dmodl(lu,modeldef, &
+ maxhpa,maxker,maxcoe, &
+ numhpa,numker,numcoe,lmxhpa, &
+ ihpakern,itypehpa,coe, &
+ itpspl,xlaspl,xlospl,radspl, &
+ numvar,ivarkern,varstr, &
+ refmdl,kerstr,hsplfl,dskker,ierror)
+ else
+ write(6,"('the model ',a,' does not exits')") modeldef(1:len_trim(modeldef))
+ endif
+
+! --- check arrays
+
+ if(numker > maxker) stop 'numker > maxker'
+ do ihpa=1,numhpa
+ if(itypehpa(ihpa) == 1) then
+ if(lmxhpa(ihpa) > maxl) stop 'lmxhpa(ihpa) > maxl'
+ else if(itypehpa(ihpa) == 2) then
+ if(numcoe(ihpa) > maxcoe) stop 'numcoe(ihpa) > maxcoe'
+ else
+ stop 'problem with itypehpa'
+ endif
+ enddo
+
+ end subroutine read_model_s362ani
+
+
+ subroutine splcon(xlat,xlon,nver,verlat,verlon,verrad,ncon,icon,con)
+
+ implicit none
+
+ integer icon(1)
+
+ real(kind=4) verlat(1)
+ real(kind=4) verlon(1)
+ real(kind=4) verrad(1)
+ real(kind=4) con(1)
+
+ double precision dd
+ double precision rn
+ double precision dr
+ double precision xrad
+ double precision ver8
+ double precision xla8
+
+ integer :: ncon,iver,nver
+
+ real(kind=4) :: xlat,xlon
+
+ xrad=3.14159265358979/180.d0
+
+ ncon=0
+
+ do iver=1,nver
+ if(xlat > verlat(iver)-2.*verrad(iver)) then
+ if(xlat < verlat(iver)+2.*verrad(iver)) then
+ ver8=xrad*(verlat(iver))
+ xla8=xrad*(xlat)
+ dd=sin(ver8)*sin(xla8)
+ dd=dd+cos(ver8)*cos(xla8)* cos(xrad*(xlon-verlon(iver)))
+ dd=acos(dd)/xrad
+ if(dd > (verrad(iver))*2.d0) then
+ else
+ ncon=ncon+1
+ icon(ncon)=iver
+ rn=dd/(verrad(iver))
+ dr=rn-1.d0
+ if(rn <= 1.d0) then
+ con(ncon)=(0.75d0*rn-1.5d0)*(rn**2)+1.d0
+ else if(rn > 1.d0) then
+ con(ncon)=((-0.25d0*dr+0.75d0)*dr-0.75d0)*dr+0.25d0
+ else
+ con(ncon)=0.
+ endif
+ endif
+ endif
+ endif
+ enddo
+
+ end subroutine splcon
+
+
+! --- evaluate perturbations in per cent
+
+ subroutine subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
+ 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)
+
+ implicit none
+
+ 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)
+
+ real(kind=4) :: xcolat,xlon,xrad
+ real(kind=4) :: dvsh,dvsv,dvph,dvpv
+
+! --- model evaluation
+
+ integer ish ! --- 0 if SV, 1 if SH
+ integer ieval ! --- 1 for velocity, 2 for anisotropy
+ real(kind=4) :: valu(2) ! --- valu(1) if S; valu(1)=velo, valu(2)=aniso
+ real(kind=4) :: value ! --- used in single evaluation of perturbation
+ integer isel ! --- if variable should be included
+ real(kind=4) :: depth ! --- depth
+ real(kind=4) :: x,y ! --- lat lon
+ real(kind=4) :: vsh3drel ! --- relative perturbation
+ real(kind=4) :: vsv3drel ! --- relative perturbation
+
+! ---
+
+ integer iker,i
+ character(len=40) vstr
+ integer lstr
+ integer ierror
+
+! -------------------------------------
+
+ depth=6371.0-xrad
+ call evradker (depth,kerstr,numker,vercof,vercofd,ierror)
+ if(ierror /= 0) stop 'ierror evradker'
+
+! --- loop over sv and sh (sv=0,sh=1)
+
+ do ish=0,1
+
+! --- contributing horizontal basis functions at xlat,xlon
+
+ y=90.0-xcolat
+ x=xlon
+ do ihpa=1,numhpa
+ if(itypehpa(ihpa) == 1) then
+ lmax=lmxhpa(ihpa)
+ call ylm(y,x,lmax,ylmcof(1,ihpa),wk1,wk2,wk3)
+ else if(itypehpa(ihpa) == 2) then
+ numcof=numcoe(ihpa)
+ call splcon(y,x,numcof,xlaspl(1,ihpa), &
+ xlospl(1,ihpa),radspl(1,ihpa), &
+ nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
+ else
+ write(6,"('problem 1')")
+ endif
+ enddo
+
+! --- evaluate 3-D perturbations in velocity and anisotropy
+
+ valu(1)=0. ! --- velocity
+ valu(2)=0. ! --- anisotropy
+
+ do ieval=1,2
+ value=0.
+ do iker=1,numker
+ isel=0
+ lstr=len_trim(varstr(ivarkern(iker)))
+ vstr=(varstr(ivarkern(iker)))
+ if(ieval == 1) then
+ if(vstr(1:lstr) == 'UM (SH+SV)*0.5,'.or. &
+ vstr(1:lstr) == 'LM (SH+SV)*0.5,'.or. &
+ vstr(1:lstr) == 'EA (SH+SV)*0.5,') then
+ isel=1
+ endif
+ else if(ieval == 2) then
+ if(vstr(1:lstr) == 'UM SH-SV,'.or. &
+ vstr(1:lstr) == 'LM SH-SV,'.or. &
+ vstr(1:lstr) == 'EA SH-SV,') then
+ isel=1
+ endif
+ endif
+
+ if(isel == 1) then
+ if(vercof(iker) /= 0.) then
+ if(itypehpa(ihpakern(iker)) == 1) then
+ ihpa=ihpakern(iker)
+ nylm=(lmxhpa(ihpakern(iker))+1)**2
+ do i=1,nylm
+ value=value+vercof(iker)*ylmcof(i,ihpa) &
+ *coe(i,iker)
+ enddo
+ else if(itypehpa(ihpakern(iker)) == 2) then
+ ihpa=ihpakern(iker)
+ do i=1,nconpt(ihpa)
+ iver=iconpt(i,ihpa)
+ value=value+vercof(iker)*conpt(i,ihpa) &
+ *coe(iver,iker)
+ enddo
+ else
+ write(6,"('problem 2')")
+ stop
+ endif ! --- itypehpa
+ endif ! --- vercof(iker) /= 0.
+ endif ! --- isel == 1
+ enddo ! --- end of do iker=1,numker
+
+ valu(ieval)=value
+ enddo ! --- ieval
+
+! --- evaluate perturbations in vsh and vsv
+
+ if(ish == 1) then
+ vsh3drel=valu(1)+0.5*valu(2)
+ else if(ish == 0) then
+ vsv3drel=valu(1)-0.5*valu(2)
+ else
+ stop 'something wrong'
+ endif
+
+ enddo ! --- by ish
+
+! --- evaluate perturbations in per cent
+
+ dvsh=vsh3drel
+ dvsv=vsv3drel
+ dvph=0.55*dvsh ! --- scaling used in the inversion
+ dvpv=0.55*dvsv ! --- scaling used in the inversion
+
+ end subroutine subshsv
+
+
+! --- evaluate depressions of the 410- and 650-km discontinuities in km
+
+ subroutine subtopo(xcolat,xlon,topo410,topo650, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,ylmcof,wk1,wk2,wk3,varstr)
+
+ implicit none
+
+ 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) 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=40) varstr(maxker)
+
+ real(kind=4) :: xcolat,xlon
+ real(kind=4) :: topo410,topo650
+
+! --- model evaluation
+
+ integer ieval ! --- 1 for velocity, 2 for anisotropy
+ real(kind=4) :: valu(2) ! --- valu(1) if S; valu(1)=velo, valu(2)=aniso
+ real(kind=4) :: value ! --- used in single evaluation of perturbation
+ integer isel ! --- if variable should be included
+ real(kind=4) :: x,y ! --- lat lon
+
+! ---
+ integer iker,i
+ character(len=40) vstr
+ integer lstr
+
+! -------------------------------------
+
+! --- contributing horizontal basis functions at xlat,xlon
+
+ y=90.0-xcolat
+ x=xlon
+ do ihpa=1,numhpa
+ if(itypehpa(ihpa) == 1) then
+ lmax=lmxhpa(ihpa)
+ call ylm(y,x,lmax,ylmcof(1,ihpa),wk1,wk2,wk3)
+ else if(itypehpa(ihpa) == 2) then
+ numcof=numcoe(ihpa)
+ call splcon(y,x,numcof,xlaspl(1,ihpa), &
+ xlospl(1,ihpa),radspl(1,ihpa), &
+ nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
+ else
+ write(6,"('problem 1')")
+ endif
+ enddo
+
+! --- evaluate topography (depression) in km
+
+ valu(1)=0. ! --- 410
+ valu(2)=0. ! --- 650
+
+ do ieval=1,2
+ value=0.
+ do iker=1,numker
+ isel=0
+ lstr=len_trim(varstr(ivarkern(iker)))
+ vstr=(varstr(ivarkern(iker)))
+ if(ieval == 1) then
+ if(vstr(1:lstr) == 'Topo 400,') then
+ isel=1
+ endif
+ else if(ieval == 2) then
+ if(vstr(1:lstr) == 'Topo 670,') then
+ isel=1
+ endif
+ endif
+
+ if(isel == 1) then
+ if(itypehpa(ihpakern(iker)) == 1) then
+ ihpa=ihpakern(iker)
+ nylm=(lmxhpa(ihpakern(iker))+1)**2
+ do i=1,nylm
+ value=value+ylmcof(i,ihpa)*coe(i,iker)
+ enddo
+ else if(itypehpa(ihpakern(iker)) == 2) then
+ ihpa=ihpakern(iker)
+ do i=1,nconpt(ihpa)
+ iver=iconpt(i,ihpa)
+ value=value+conpt(i,ihpa)*coe(iver,iker)
+ enddo
+ else
+ write(6,"('problem 2')")
+ stop
+ endif ! --- itypehpa
+ endif ! --- isel == 1
+ enddo ! --- end of do iker=1,numker
+
+ valu(ieval)=value
+ enddo ! --- ieval
+
+ topo410=valu(1)
+ topo650=valu(2)
+
+ end subroutine subtopo
+
+ subroutine vbspl(x,np,xarr,splcon,splcond)
+!
+!---- this subroutine returns the spline contributions at a particular value of x
+!
+ implicit none
+
+ integer :: np
+
+ real(kind=4) :: xarr(np),x
+ real(kind=4) :: splcon(np)
+ real(kind=4) :: splcond(np)
+
+ real(kind=4) :: r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13
+ real(kind=4) :: r1d,r2d,r3d,r4d,r5d,r6d,r7d,r8d,r9d,r10d,r11d,r12d,r13d,val,vald
+
+ real(kind=4) :: rr1,rr2,rr3,rr4,rr5,rr6,rr7,rr8,rr9,rr10,rr11,rr12
+ real(kind=4) :: rr1d,rr2d,rr3d,rr4d,rr5d,rr6d,rr7d,rr8d,rr9d,rr10d,rr11d,rr12d
+
+ integer :: iflag,interval,ik,ib
+
+!
+!---- iflag=1 ==>> second derivative is 0 at end points
+!---- iflag=0 ==>> first derivative is 0 at end points
+!
+ iflag=1
+!
+!---- first, find out within which interval x falls
+!
+ interval=0
+ ik=1
+ do while(interval == 0.and.ik < np)
+ ik=ik+1
+ if(x >= xarr(ik-1).and.x <= xarr(ik)) interval=ik-1
+ enddo
+ if(x > xarr(np)) then
+ interval=np
+ endif
+
+ if(interval == 0) then
+! write(6,"('low value:',2f10.3)") x,xarr(1)
+ else if(interval > 0.and.interval < np) then
+! write(6,"('bracket:',i5,3f10.3)") interval,xarr(interval),x,xarr(interval+1)
+ else
+! write(6,"('high value:',2f10.3)") xarr(np),x
+ endif
+
+ do ib=1,np
+ val=0.
+ vald=0.
+ if(ib == 1) then
+
+ r1=(x-xarr(1))/(xarr(2)-xarr(1))
+ r2=(xarr(3)-x)/(xarr(3)-xarr(1))
+ r4=(xarr(2)-x)/(xarr(2)-xarr(1))
+ r5=(x-xarr(1))/(xarr(2)-xarr(1))
+ r6=(xarr(3)-x)/(xarr(3)-xarr(1))
+ r10=(xarr(2)-x)/(xarr(2)-xarr(1))
+ r11=(x-xarr(1)) /(xarr(2)-xarr(1))
+ r12=(xarr(3)-x)/(xarr(3)-xarr(2))
+ r13=(xarr(2)-x)/(xarr(2)-xarr(1))
+
+ r1d=1./(xarr(2)-xarr(1))
+ r2d=-1./(xarr(3)-xarr(1))
+ r4d=-1./(xarr(2)-xarr(1))
+ r5d=1./(xarr(2)-xarr(1))
+ r6d=-1./(xarr(3)-xarr(1))
+ r10d=-1./(xarr(2)-xarr(1))
+ r11d=1./(xarr(2)-xarr(1))
+ r12d=-1./(xarr(3)-xarr(2))
+ r13d=-1./(xarr(2)-xarr(1))
+
+ if(interval == ib.or.interval == 0) then
+ if(iflag == 0) then
+ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11 +r13**3
+ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
+ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
+ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
+ vald=vald+3.*r13d*r13**2
+ else if(iflag == 1) then
+ val=0.6667*(r1*r4*r10 + r2*r5*r10 + r2*r6*r11 &
+ + 1.5*r13**3)
+ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
+ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
+ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
+ vald=vald+4.5*r13d*r13**2
+ vald=0.6667*vald
+ endif
+ else if(interval == ib+1) then
+ if(iflag == 0) then
+ val=r2*r6*r12
+ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
+ else if(iflag == 1) then
+ val=0.6667*r2*r6*r12
+ vald=0.6667*(r2d*r6*r12+r2*r6d*r12+r2*r6*r12d)
+ endif
+ else
+ val=0.
+ endif
+
+ else if(ib == 2) then
+
+ rr1=(x-xarr(1))/(xarr(2)-xarr(1))
+ rr2=(xarr(3)-x)/(xarr(3)-xarr(1))
+ rr4=(xarr(2)-x)/(xarr(2)-xarr(1))
+ rr5=(x-xarr(1))/(xarr(2)-xarr(1))
+ rr6=(xarr(3)-x)/(xarr(3)-xarr(1))
+ rr10=(xarr(2)-x)/(xarr(2)-xarr(1))
+ rr11=(x-xarr(1)) /(xarr(2)-xarr(1))
+ rr12=(xarr(3)-x)/(xarr(3)-xarr(2))
+
+ rr1d=1./(xarr(2)-xarr(1))
+ rr2d=-1./(xarr(3)-xarr(1))
+ rr4d=-1./(xarr(2)-xarr(1))
+ rr5d=1./(xarr(2)-xarr(1))
+ rr6d=-1./(xarr(3)-xarr(1))
+ rr10d=-1./(xarr(2)-xarr(1))
+ rr11d=1./(xarr(2)-xarr(1))
+ rr12d=-1./(xarr(3)-xarr(2))
+
+ r1=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
+ r2=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib-1))
+ r3=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
+ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
+ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
+ r6=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib))
+ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
+ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
+ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
+ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
+ r12=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib+1))
+
+ r1d=1./(xarr(ib+1)-xarr(ib-1))
+ r2d=-1./(xarr(ib+2)-xarr(ib-1))
+ r3d=1./(xarr(ib)-xarr(ib-1))
+ r4d=-1./(xarr(ib+1)-xarr(ib-1))
+ r5d=1./(xarr(ib+1)-xarr(ib-1))
+ r6d=-1./(xarr(ib+2)-xarr(ib))
+ r8d=-1./ (xarr(ib)-xarr(ib-1))
+ r9d=1./(xarr(ib)-xarr(ib-1))
+ r10d=-1./(xarr(ib+1)-xarr(ib))
+ r11d=1./(xarr(ib+1)-xarr(ib))
+ r12d=-1./(xarr(ib+2)-xarr(ib+1))
+
+ if(interval == ib-1.or.interval == 0) then
+ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
+ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
+ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
+ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
+ if(iflag == 1) then
+ val=val+0.3333*(rr1*rr4*rr10 + rr2*rr5*rr10 + &
+ rr2*rr6*rr11)
+ vald=vald+0.3333*(rr1d*rr4*rr10+rr1*rr4d*rr10+ &
+ rr1*rr4*rr10d)
+ vald=vald+0.3333*(rr2d*rr5*rr10+rr2*rr5d*rr10+ &
+ rr2*rr5*rr10d)
+ vald=vald+0.3333*(rr2d*rr6*rr11+rr2*rr6d*rr11+ &
+ rr2*rr6*rr11d)
+ endif
+ else if(interval == ib) then
+ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
+ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
+ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
+ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
+ if(iflag == 1) then
+ val=val+0.3333*rr2*rr6*rr12
+ vald=vald+0.3333*(rr2d*rr6*rr12+rr2*rr6d*rr12+ &
+ rr2*rr6*rr12d)
+ endif
+ else if(interval == ib+1) then
+ val=r2*r6*r12
+ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
+ else
+ val=0.
+ endif
+ else if(ib == np-1) then
+
+ rr1=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
+ rr2=(xarr(np)-x)/(xarr(np)-xarr(np-1))
+ rr3=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
+ rr4=(xarr(np)-x)/(xarr(np)-xarr(np-1))
+ rr5=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
+ rr7=(x-xarr(np-2))/(xarr(np-1)-xarr(np-2))
+ rr8=(xarr(np)-x)/ (xarr(np)-xarr(np-1))
+ rr9=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
+
+ rr1d=1./(xarr(np)-xarr(np-2))
+ rr2d=-1./(xarr(np)-xarr(np-1))
+ rr3d=1./(xarr(np)-xarr(np-2))
+ rr4d=-1./(xarr(np)-xarr(np-1))
+ rr5d=1./(xarr(np)-xarr(np-1))
+ rr7d=1./(xarr(np-1)-xarr(np-2))
+ rr8d=-1./ (xarr(np)-xarr(np-1))
+ rr9d=1./(xarr(np)-xarr(np-1))
+
+ r1=(x-xarr(ib-2))/(xarr(ib+1)-xarr(ib-2))
+ r2=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
+ r3=(x-xarr(ib-2))/(xarr(ib)-xarr(ib-2))
+ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
+ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
+ r6=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
+ r7=(x-xarr(ib-2))/(xarr(ib-1)-xarr(ib-2))
+ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
+ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
+ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
+ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
+
+ r1d=1./(xarr(ib+1)-xarr(ib-2))
+ r2d=-1./(xarr(ib+1)-xarr(ib-1))
+ r3d=1./(xarr(ib)-xarr(ib-2))
+ r4d=-1./(xarr(ib+1)-xarr(ib-1))
+ r5d=1./(xarr(ib+1)-xarr(ib-1))
+ r6d=-1./(xarr(ib+1)-xarr(ib))
+ r7d=1./(xarr(ib-1)-xarr(ib-2))
+ r8d=-1./(xarr(ib)-xarr(ib-1))
+ r9d=1./(xarr(ib)-xarr(ib-1))
+ r10d=-1./(xarr(ib+1)-xarr(ib))
+ r11d=1./(xarr(ib+1)-xarr(ib))
+
+ if(interval == ib-2) then
+ val=r1*r3*r7
+ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
+ else if(interval == ib-1) then
+ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
+ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
+ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
+ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
+ if(iflag == 1) then
+ val=val+0.3333*rr1*rr3*rr7
+ vald=vald+0.3333*(rr1d*rr3*rr7+rr1*rr3d*rr7+ &
+ rr1*rr3*rr7d)
+ endif
+ else if(interval == ib.or.interval == np) then
+ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
+ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
+ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
+ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
+ if(iflag == 1) then
+ val=val+0.3333*(rr1*rr3*rr8 + rr1*rr4*rr9 + &
+ rr2*rr5*rr9)
+ vald=vald+0.3333*(rr1d*rr3*rr8+rr1*rr3d*rr8+ &
+ rr1*rr3*rr8d)
+ vald=vald+0.3333*(rr1d*rr4*rr9+rr1*rr4d*rr9+ &
+ rr1*rr4*rr9d)
+ vald=vald+0.3333*(rr2d*rr5*rr9+rr2*rr5d*rr9+ &
+ rr2*rr5*rr9d)
+ endif
+ else
+ val=0.
+ endif
+ else if(ib == np) then
+
+ r1=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
+ r2=(xarr(np)-x)/(xarr(np)-xarr(np-1))
+ r3=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
+ r4=(xarr(np)-x)/(xarr(np)-xarr(np-1))
+ r5=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
+ r7=(x-xarr(np-2))/(xarr(np-1)-xarr(np-2))
+ r8=(xarr(np)-x)/ (xarr(np)-xarr(np-1))
+ r9=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
+ r13=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
+
+ r1d=1./(xarr(np)-xarr(np-2))
+ r2d=-1./(xarr(np)-xarr(np-1))
+ r3d=1./(xarr(np)-xarr(np-2))
+ r4d=-1./(xarr(np)-xarr(np-1))
+ r5d=1./(xarr(np)-xarr(np-1))
+ r7d=1./(xarr(np-1)-xarr(np-2))
+ r8d=-1./ (xarr(np)-xarr(np-1))
+ r9d=1./(xarr(np)-xarr(np-1))
+ r13d=1./(xarr(np)-xarr(np-1))
+
+ if(interval == np-2) then
+ if(iflag == 0) then
+ val=r1*r3*r7
+ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
+ else if(iflag == 1) then
+ val=0.6667*r1*r3*r7
+ vald=0.6667*(r1d*r3*r7+r1*r3d*r7+r1*r3*r7d)
+ endif
+ else if(interval == np-1.or.interval == np) then
+ if(iflag == 0) then
+ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + r13**3
+ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
+ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
+ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
+ vald=vald+3.*r13d*r13**2
+ else if(iflag == 1) then
+ val=0.6667*(r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + &
+ 1.5*r13**3)
+ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
+ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
+ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
+ vald=vald+4.5*r13d*r13**2
+ vald=0.6667*vald
+ endif
+ else
+ val=0.
+ endif
+ else
+
+ r1=(x-xarr(ib-2))/(xarr(ib+1)-xarr(ib-2))
+ r2=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib-1))
+ r3=(x-xarr(ib-2))/(xarr(ib)-xarr(ib-2))
+ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
+ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
+ r6=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib))
+ r7=(x-xarr(ib-2))/(xarr(ib-1)-xarr(ib-2))
+ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
+ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
+ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
+ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
+ r12=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib+1))
+
+ r1d=1./(xarr(ib+1)-xarr(ib-2))
+ r2d=-1./(xarr(ib+2)-xarr(ib-1))
+ r3d=1./(xarr(ib)-xarr(ib-2))
+ r4d=-1./(xarr(ib+1)-xarr(ib-1))
+ r5d=1./(xarr(ib+1)-xarr(ib-1))
+ r6d=-1./(xarr(ib+2)-xarr(ib))
+ r7d=1./(xarr(ib-1)-xarr(ib-2))
+ r8d=-1./ (xarr(ib)-xarr(ib-1))
+ r9d=1./(xarr(ib)-xarr(ib-1))
+ r10d=-1./(xarr(ib+1)-xarr(ib))
+ r11d=1./(xarr(ib+1)-xarr(ib))
+ r12d=-1./(xarr(ib+2)-xarr(ib+1))
+
+ if(interval == ib-2) then
+ val=r1*r3*r7
+ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
+ else if(interval == ib-1) then
+ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
+ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
+ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
+ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
+ else if(interval == ib) then
+ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
+ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
+ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
+ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
+ else if(interval == ib+1) then
+ val=r2*r6*r12
+ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
+ else
+ val=0.
+ endif
+ endif
+ splcon(ib)=val
+ splcond(ib)=vald
+ enddo
+
+ end subroutine vbspl
+
+
+ subroutine ylm(XLAT,XLON,LMAX,Y,WK1,WK2,WK3)
+
+ implicit none
+
+ complex TEMP,FAC,DFAC
+
+ real(kind=4) WK1(1),WK2(1),WK3(1),Y(1),XLAT,XLON
+
+ integer :: LMAX
+
+!
+! WK1,WK2,WK3 SHOULD BE DIMENSIONED AT LEAST (LMAX+1)*4
+!
+ real(kind=4), parameter :: RADIAN = 57.2957795
+
+ integer :: IM,IL1,IND,LM1,L
+
+ real(kind=4) :: THETA,PHI
+
+ THETA=(90.-XLAT)/RADIAN
+ PHI=XLON/RADIAN
+
+ IND=0
+ LM1=LMAX+1
+
+ DO IL1=1,LM1
+
+ L=IL1-1
+ CALL legndr(THETA,L,L,WK1,WK2,WK3)
+
+ FAC=(1.,0.)
+ DFAC=CEXP(CMPLX(0.,PHI))
+
+ do IM=1,IL1
+ TEMP=FAC*CMPLX(WK1(IM),0.)
+ IND=IND+1
+ Y(IND)=REAL(TEMP)
+ IF(IM == 1) GOTO 20
+ IND=IND+1
+ Y(IND)=AIMAG(TEMP)
+ 20 FAC=FAC*DFAC
+ enddo
+
+ enddo
+
+ end subroutine ylm
+
+!------------------------------------
+
+ subroutine legndr(THETA,L,M,X,XP,XCOSEC)
+
+ implicit none
+
+ real(kind=4) :: X(2),XP(2),XCOSEC(2)
+
+ double precision :: SMALL,SUM,COMPAR,CT,ST,FCT,COT,X1,X2,X3,F1,F2,XM,TH
+
+ double precision, parameter :: FPI = 12.56637062D0
+
+ integer :: i,M,MP1,k,l,LP1
+
+ real(kind=4) :: THETA,DSFL3,COSEC,SFL3
+
+!!!!!! illegal statement, removed by Dimitri Komatitsch DFLOAT(I)=FLOAT(I)
+
+ SUM=0.D0
+ LP1=L+1
+ TH=THETA
+ CT=DCOS(TH)
+ ST=DSIN(TH)
+ MP1=M+1
+ FCT=DSQRT(dble(2*L+1)/FPI)
+ SFL3=SQRT(FLOAT(L*(L+1)))
+ COMPAR=dble(2*L+1)/FPI
+ DSFL3=SFL3
+ SMALL=1.D-16*COMPAR
+
+ do I=1,MP1
+ X(I)=0.
+ XCOSEC(I)=0.
+ XP(I)=0.
+ enddo
+
+ IF(L > 1.AND.ABS(THETA) > 1.E-5) GO TO 3
+ X(1)=FCT
+ IF(L == 0) RETURN
+ X(1)=CT*FCT
+ X(2)=-ST*FCT/DSFL3
+ XP(1)=-ST*FCT
+ XP(2)=-.5D0*CT*FCT*DSFL3
+ IF(ABS(THETA) < 1.E-5) XCOSEC(2)=XP(2)
+ IF(ABS(THETA) >= 1.E-5) XCOSEC(2)=X(2)/ST
+ RETURN
+
+ 3 X1=1.D0
+ X2=CT
+
+ do I=2,L
+ X3=(dble(2*I-1)*CT*X2-dble(I-1)*X1)/dble(I)
+ X1=X2
+ X2=X3
+ enddo
+
+ COT=CT/ST
+ COSEC=1./ST
+ X3=X2*FCT
+ X2=dble(L)*(X1-CT*X2)*FCT/ST
+ X(1)=X3
+ X(2)=X2
+ SUM=X3*X3
+ XP(1)=-X2
+ XP(2)=dble(L*(L+1))*X3-COT*X2
+ X(2)=-X(2)/SFL3
+ XCOSEC(2)=X(2)*COSEC
+ XP(2)=-XP(2)/SFL3
+ SUM=SUM+2.D0*X(2)*X(2)
+ IF(SUM-COMPAR > SMALL) RETURN
+ X1=X3
+ X2=-X2/DSQRT(dble(L*(L+1)))
+
+ do I=3,MP1
+ K=I-1
+ F1=DSQRT(dble((L+I-1)*(L-I+2)))
+ F2=DSQRT(dble((L+I-2)*(L-I+3)))
+ XM=K
+ X3=-(2.D0*COT*(XM-1.D0)*X2+F2*X1)/F1
+ SUM=SUM+2.D0*X3*X3
+ IF(SUM-COMPAR > SMALL.AND.I /= LP1) RETURN
+ X(I)=X3
+ XCOSEC(I)=X(I)*COSEC
+ X1=X2
+ XP(I)=-(F1*X2+XM*COT*X3)
+ X2=X3
+ enddo
+
+ end subroutine legndr
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/save_header_file.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/save_header_file.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/save_header_file.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/save_header_file.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,490 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! save header file OUTPUT_FILES/values_from_mesher.h
+
+ subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP,&
+ static_memory_size,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
+ NPROC_XI,NPROC_ETA, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, nglob
+
+ integer NEX_XI,NEX_ETA,NPROC,NPROCTOT,NCHUNKS,NSOURCES,NSTEP
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D,INCLUDE_CENTRAL_CUBE
+
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
+ CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH
+
+ double precision :: subtract_central_cube_elems,subtract_central_cube_points
+
+ character(len=150) HEADER_FILE
+
+! for regional code
+ double precision x,y,gamma,rgt,xi,eta
+ double precision x_top,y_top,z_top
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! rotation matrix from Euler angles
+ integer i,j,ix,iy,icorner
+ double precision rotation_matrix(3,3)
+ double precision vector_ori(3),vector_rotated(3)
+ double precision r_corner,theta_corner,phi_corner,lat,long,colat_corner
+
+! static memory size needed by the solver
+ double precision :: static_memory_size
+
+ integer :: att1,att2,att3,att4,att5,NCORNERSCHUNKS,NUM_FACES,NUM_MSG_TYPES
+
+ integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NSPEC2D_TOP,NSPEC2D_BOTTOM,NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX
+ integer :: NPROC_XI,NPROC_ETA
+
+ integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION, &
+ NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670, NSPEC2D_CMB, NSPEC2D_ICB
+
+! copy number of elements and points in an include file for the solver
+ call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
+ open(unit=IOUT,file=HEADER_FILE,status='unknown')
+ write(IOUT,*)
+
+ write(IOUT,*) '!'
+ write(IOUT,*) '! this is the parameter file for static compilation of the solver'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! mesh statistics:'
+ write(IOUT,*) '! ---------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of chunks = ',NCHUNKS
+ write(IOUT,*) '!'
+
+! the central cube is counted 6 times, therefore remove 5 times
+ if(INCLUDE_CENTRAL_CUBE) then
+ write(IOUT,*) '! these statistics include the central cube'
+ subtract_central_cube_elems = 5.d0 * dble((NEX_XI/8))**3
+ subtract_central_cube_points = 5.d0 * (dble(NEX_XI/8)*dble(NGLLX-1)+1.d0)**3
+ else
+ write(IOUT,*) '! these statistics do not include the central cube'
+ subtract_central_cube_elems = 0.d0
+ subtract_central_cube_points = 0.d0
+ endif
+
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of processors = ',NPROCTOT
+ write(IOUT,*) '!'
+ write(IOUT,*) '! maximum number of points per region = ',nglob(IREGION_CRUST_MANTLE)
+ write(IOUT,*) '!'
+! use fused loops on NEC SX
+ write(IOUT,*) '! on NEC SX, make sure "loopcnt=" parameter'
+ write(IOUT,*) '! in Makefile is greater than max vector length = ',nglob(IREGION_CRUST_MANTLE)*NDIM
+ write(IOUT,*) '!'
+
+ write(IOUT,*) '! total elements per slice = ',sum(NSPEC)
+ write(IOUT,*) '! total points per slice = ',sum(nglob)
+ write(IOUT,*) '!'
+
+ write(IOUT,*) '! total for full 6-chunk mesh:'
+ write(IOUT,*) '! ---------------------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! exact total number of spectral elements in entire mesh = '
+ write(IOUT,*) '! ',6.d0*dble(NPROC)*dble(sum(NSPEC)) - subtract_central_cube_elems
+ write(IOUT,*) '! approximate total number of points in entire mesh = '
+ write(IOUT,*) '! ',2.d0*dble(NPROC)*(3.d0*dble(sum(nglob))) - subtract_central_cube_points
+! there are 3 DOFs in solid regions, but only 1 in fluid outer core
+ write(IOUT,*) '! approximate total number of degrees of freedom in entire mesh = '
+ write(IOUT,*) '! ',6.d0*dble(NPROC)*(3.d0*(dble(sum(nglob))) &
+ - 2.d0*dble(nglob(IREGION_OUTER_CORE))) &
+ - 3.d0*subtract_central_cube_points
+ write(IOUT,*) '!'
+
+! display location of chunk if regional run
+ if(NCHUNKS /= 6) then
+
+ write(IOUT,*) '! position of the mesh chunk at the surface:'
+ write(IOUT,*) '! -----------------------------------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! angular size in first direction in degrees = ',sngl(ANGULAR_WIDTH_XI_IN_DEGREES)
+ write(IOUT,*) '! angular size in second direction in degrees = ',sngl(ANGULAR_WIDTH_ETA_IN_DEGREES)
+ write(IOUT,*) '!'
+ write(IOUT,*) '! longitude of center in degrees = ',sngl(CENTER_LONGITUDE_IN_DEGREES)
+ write(IOUT,*) '! latitude of center in degrees = ',sngl(CENTER_LATITUDE_IN_DEGREES)
+ write(IOUT,*) '!'
+ write(IOUT,*) '! angle of rotation of the first chunk = ',sngl(GAMMA_ROTATION_AZIMUTH)
+
+! convert width to radians
+ ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * DEGREES_TO_RADIANS
+ ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * DEGREES_TO_RADIANS
+
+! compute rotation matrix from Euler angles
+ call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
+
+! loop on the four corners of the chunk to display their coordinates
+ icorner = 0
+ do iy = 0,1
+ do ix = 0,1
+
+ icorner = icorner + 1
+
+ xi= - ANGULAR_WIDTH_XI_RAD/2. + dble(ix)*ANGULAR_WIDTH_XI_RAD
+ eta= - ANGULAR_WIDTH_ETA_RAD/2. + dble(iy)*ANGULAR_WIDTH_ETA_RAD
+
+ x=dtan(xi)
+ y=dtan(eta)
+
+ gamma=ONE/dsqrt(ONE+x*x+y*y)
+ rgt=R_UNIT_SPHERE*gamma
+
+! define the mesh points at the top surface
+ x_top=-y*rgt
+ y_top=x*rgt
+ z_top=rgt
+
+! rotate top
+ vector_ori(1) = x_top
+ vector_ori(2) = y_top
+ vector_ori(3) = z_top
+ do i=1,3
+ vector_rotated(i)=0.0d0
+ do j=1,3
+ vector_rotated(i)=vector_rotated(i)+rotation_matrix(i,j)*vector_ori(j)
+ enddo
+ enddo
+ x_top = vector_rotated(1)
+ y_top = vector_rotated(2)
+ z_top = vector_rotated(3)
+
+! convert to latitude and longitude
+ call xyz_2_rthetaphi_dble(x_top,y_top,z_top,r_corner,theta_corner,phi_corner)
+ call reduce(theta_corner,phi_corner)
+
+! convert geocentric to geographic colatitude
+ colat_corner=PI/2.0d0-datan(1.006760466d0*dcos(theta_corner)/dmax1(TINYVAL,dsin(theta_corner)))
+ if(phi_corner>PI) phi_corner=phi_corner-TWO_PI
+
+! compute real position of the source
+ lat = (PI/2.0d0-colat_corner)*180.0d0/PI
+ long = phi_corner*180.0d0/PI
+
+ write(IOUT,*) '!'
+ write(IOUT,*) '! corner ',icorner
+ write(IOUT,*) '! longitude in degrees = ',long
+ write(IOUT,*) '! latitude in degrees = ',lat
+
+ enddo
+ enddo
+
+ write(IOUT,*) '!'
+
+ endif ! regional chunk
+
+ write(IOUT,*) '! resolution of the mesh at the surface:'
+ write(IOUT,*) '! -------------------------------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! spectral elements along a great circle = ',4*NEX_XI
+ write(IOUT,*) '! GLL points along a great circle = ',4*NEX_XI*(NGLLX-1)
+ write(IOUT,*) '! average distance between points in degrees = ',360./real(4*NEX_XI*(NGLLX-1))
+ write(IOUT,*) '! average distance between points in km = ',real(TWO_PI*R_EARTH/1000.d0)/real(4*NEX_XI*(NGLLX-1))
+ write(IOUT,*) '! average size of a spectral element in km = ',real(TWO_PI*R_EARTH/1000.d0)/real(4*NEX_XI)
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of time steps = ',NSTEP
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of seismic sources = ',NSOURCES
+ write(IOUT,*) '!'
+ write(IOUT,*)
+
+ write(IOUT,*) '! approximate static memory needed by the solver:'
+ write(IOUT,*) '! ----------------------------------------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! size of static arrays per slice = ',static_memory_size/1073741824.d0,' GB'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! (should be below and typically equal to 80% of 1.5 GB = 1.2 GB on pangu'
+ write(IOUT,*) '! at Caltech, and below and typically equal to 85% of 2 GB = 1.7 GB'
+ write(IOUT,*) '! on Marenostrum in Barcelona)'
+ write(IOUT,*) '! (if significantly more, the job will not run by lack of memory)'
+ write(IOUT,*) '! (if significantly less, you waste a significant amount of memory)'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GB'
+ write(IOUT,*) '! = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TB'
+ write(IOUT,*) '!'
+
+ write(IOUT,*)
+ write(IOUT,*) 'integer, parameter :: NEX_XI_VAL = ',NEX_XI
+ write(IOUT,*) 'integer, parameter :: NEX_ETA_VAL = ',NEX_ETA
+ write(IOUT,*)
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE = ',NSPEC(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE = ',NSPEC(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE = ',NSPEC(IREGION_INNER_CORE)
+ write(IOUT,*)
+ write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE = ',nglob(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB_OUTER_CORE = ',nglob(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB_INNER_CORE = ',nglob(IREGION_INNER_CORE)
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_ANISO_IC = ',NSPECMAX_ANISO_IC
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_ISO_MANTLE = ',NSPECMAX_ISO_MANTLE
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_TISO_MANTLE = ',NSPECMAX_TISO_MANTLE
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_ANISO_MANTLE = ',NSPECMAX_ANISO_MANTLE
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_ATTENUAT = ',NSPEC_CRUST_MANTLE_ATTENUAT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_ATTENUATION = ',NSPEC_INNER_CORE_ATTENUATION
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STR_OR_ATT = ',NSPEC_CRUST_MANTLE_STR_OR_ATT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STR_OR_ATT = ',NSPEC_INNER_CORE_STR_OR_ATT
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STR_AND_ATT = ',NSPEC_CRUST_MANTLE_STR_AND_ATT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STR_AND_ATT = ',NSPEC_INNER_CORE_STR_AND_ATT
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STRAIN_ONLY = ',NSPEC_CRUST_MANTLE_STRAIN_ONLY
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STRAIN_ONLY = ',NSPEC_INNER_CORE_STRAIN_ONLY
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_ADJOINT = ',NSPEC_CRUST_MANTLE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ADJOINT = ',NSPEC_OUTER_CORE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_ADJOINT = ',NSPEC_INNER_CORE_ADJOINT
+
+ write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE_ADJOINT = ',NGLOB_CRUST_MANTLE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NGLOB_OUTER_CORE_ADJOINT = ',NGLOB_OUTER_CORE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NGLOB_INNER_CORE_ADJOINT = ',NGLOB_INNER_CORE_ADJOINT
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ROT_ADJOINT = ',NSPEC_OUTER_CORE_ROT_ADJOINT
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STACEY = ',NSPEC_CRUST_MANTLE_STACEY
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_STACEY = ',NSPEC_OUTER_CORE_STACEY
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE_OCEANS = ',NGLOB_CRUST_MANTLE_OCEANS
+ write(IOUT,*)
+
+! this to allow for code elimination by compiler in solver for performance
+
+ if(TRANSVERSE_ISOTROPY) then
+ write(IOUT,*) 'logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ANISOTROPIC_3D_MANTLE) then
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ANISOTROPIC_INNER_CORE) then
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ATTENUATION) then
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ATTENUATION_3D) then
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_3D_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_3D_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ELLIPTICITY) then
+ write(IOUT,*) 'logical, parameter :: ELLIPTICITY_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ELLIPTICITY_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(GRAVITY) then
+ write(IOUT,*) 'logical, parameter :: GRAVITY_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: GRAVITY_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ROTATION) then
+ write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .false.'
+ endif
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ROTATION = ',NSPEC_OUTER_CORE_ROTATION
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_CM = ',NGLOB1D_RADIAL(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_OC = ',NGLOB1D_RADIAL(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_IC = ',NGLOB1D_RADIAL(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_CM = ',NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_OC = ',NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_IC = ',NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_CM = ',NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_OC = ',NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_IC = ',NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NPROC_XI_VAL = ',NPROC_XI
+ write(IOUT,*) 'integer, parameter :: NPROC_ETA_VAL = ',NPROC_ETA
+ write(IOUT,*) 'integer, parameter :: NCHUNKS_VAL = ',NCHUNKS
+ write(IOUT,*) 'integer, parameter :: NPROCTOT_VAL = ',NPROCTOT
+
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_VAL_CM = ', &
+ max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE))
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_VAL_OC = ', &
+ max(NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE))
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_VAL_IC = ', &
+ max(NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE))
+
+ 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
+ endif
+
+ write(IOUT,*) 'integer, parameter :: NUMMSGS_FACES_VAL = ',NPROC_XI*NUM_FACES*NUM_MSG_TYPES
+ write(IOUT,*) 'integer, parameter :: NCORNERSCHUNKS_VAL = ',NCORNERSCHUNKS
+
+ if(ATTENUATION) then
+ if(ATTENUATION_3D) then
+ att1 = NGLLX
+ att2 = NGLLY
+ att3 = NGLLZ
+ att4 = NSPEC(IREGION_CRUST_MANTLE)
+ att5 = NSPEC(IREGION_INNER_CORE)
+ else
+ att1 = 1
+ att2 = 1
+ att3 = 1
+ att4 = NRAD_ATTENUATION
+ att5 = NRAD_ATTENUATION
+ endif
+ else
+ att1 = 1
+ att2 = 1
+ att3 = 1
+ att4 = 1
+ att5 = 1
+ endif
+
+ write(IOUT,*) 'integer, parameter :: ATT1 = ',att1
+ write(IOUT,*) 'integer, parameter :: ATT2 = ',att2
+ write(IOUT,*) 'integer, parameter :: ATT3 = ',att3
+ write(IOUT,*) 'integer, parameter :: ATT4 = ',att4
+ write(IOUT,*) 'integer, parameter :: ATT5 = ',att5
+
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_XMIN_XMAX_CM = ',NSPEC2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_YMIN_YMAX_CM = ',NSPEC2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_BOTTOM_CM = ',NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_TOP_CM = ',NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_XMIN_XMAX_IC = ',NSPEC2DMAX_XMIN_XMAX(IREGION_INNER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_YMIN_YMAX_IC = ',NSPEC2DMAX_YMIN_YMAX(IREGION_INNER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_BOTTOM_IC = ',NSPEC2D_BOTTOM(IREGION_INNER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_TOP_IC = ',NSPEC2D_TOP(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_XMIN_XMAX_OC = ',NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_YMIN_YMAX_OC = ',NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_BOTTOM_OC = ',NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_TOP_OC = ',NSPEC2D_TOP(IREGION_OUTER_CORE)
+
+ ! for boundary kernels
+
+ if (SAVE_BOUNDARY_MESH) then
+ NSPEC2D_MOHO = NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ NSPEC2D_400 = NSPEC2D_MOHO / 4
+ NSPEC2D_670 = NSPEC2D_400
+ NSPEC2D_CMB = NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
+ NSPEC2D_ICB = NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
+ else
+ NSPEC2D_MOHO = 1
+ NSPEC2D_400 = 1
+ NSPEC2D_670 = 1
+ NSPEC2D_CMB = 1
+ NSPEC2D_ICB = 1
+ endif
+
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_MOHO = ',NSPEC2D_MOHO
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_400 = ',NSPEC2D_400
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_670 = ',NSPEC2D_670
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_CMB = ',NSPEC2D_CMB
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_ICB = ',NSPEC2D_ICB
+
+ close(IOUT)
+
+ end subroutine save_header_file
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sea99_s_model.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sea99_s_model.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sea99_s_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sea99_s_model.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,157 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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_sea99_s_model(SEA99M_V)
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+ integer :: i,ia,io,j
+
+!----------------------- choose input file: ------------------
+! relative anomaly
+
+
+ open(1,file='DATA/Lebedev_sea99/sea99_dvsvs')
+
+!----------------------- read input file: ------------------
+
+ do i = 1, 6
+ read(1,*)
+ enddo
+ read(1,*) SEA99M_V%sea99_ndep
+ read(1,*) (SEA99M_V%sea99_depth(i), i = 1, SEA99M_V%sea99_ndep)
+ read(1,*)
+ read(1,*) SEA99M_V%alatmin, SEA99M_V%alatmax
+ read(1,*) SEA99M_V%alonmin, SEA99M_V%alonmax
+ read(1,*) SEA99M_V%sea99_ddeg,SEA99M_V%sea99_nlat,SEA99M_V%sea99_nlon
+ if (SEA99M_V%sea99_nlat .ne. nint((SEA99M_V%alatmax-SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg)+1) then
+ stop 'alatmin,alatmax,sea99_nlat'
+ endif
+ if (SEA99M_V%sea99_nlon .ne. nint((SEA99M_V%alonmax-SEA99M_V%alonmin)/SEA99M_V%sea99_ddeg)+1) then
+ stop 'alonmin,alonmax,sea99_nlon'
+ endif
+ read(1,*)
+ do j = 1, SEA99M_V%sea99_ndep
+ do ia = 1, SEA99M_V%sea99_nlat
+ read (1,*) (SEA99M_V%sea99_vs(ia,io,j), io = 1, SEA99M_V%sea99_nlon)
+ enddo
+ enddo
+
+end subroutine read_sea99_s_model
+
+subroutine sea99_s_model(radius,theta,phi,dvs,SEA99M_V)
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+ integer :: id1,i,ilat,ilon
+ double precision :: alat1,alon1,radius,theta,phi,dvs
+ double precision :: xxx,yyy,dep,pla,plo,xd1,dd1,dd2,ddd(2)
+ !----------------------- depth in the model ------------------
+ dep=R_EARTH_KM*(R_UNIT_SPHERE - radius)
+ pla=90.0d0 - theta/DEGREES_TO_RADIANS
+ plo=phi/DEGREES_TO_RADIANS
+ if (dep .le. SEA99M_V%sea99_depth(1)) then
+ id1 = 1
+ xd1 = 0
+ else if (dep .ge. SEA99M_V%sea99_depth(SEA99M_V%sea99_ndep)) then
+ id1 = SEA99M_V%sea99_ndep
+ xd1 = 0
+ else
+ do i = 2, SEA99M_V%sea99_ndep
+ if (dep .le. SEA99M_V%sea99_depth(i)) then
+ id1 = i-1
+ xd1 = (dep-SEA99M_V%sea99_depth(i-1)) / (SEA99M_V%sea99_depth(i) - SEA99M_V%sea99_depth(i-1))
+ go to 1
+ endif
+ enddo
+ endif
+1 continue
+
+!----------------------- value at a point ---------------------
+!----- approximate interpolation, OK for the (dense) 1-degree sampling ------
+
+ ilat = int((pla - SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg) + 1
+ ilon = int((plo - SEA99M_V%alonmin)/SEA99M_V%sea99_ddeg) + 1
+ alat1 = SEA99M_V%alatmin + (ilat-1)*SEA99M_V%sea99_ddeg
+ alon1 = SEA99M_V%alonmin + (ilon-1)*SEA99M_V%sea99_ddeg
+
+ do i = 1, 2
+ xxx = (pla-alat1)/SEA99M_V%sea99_ddeg
+ yyy = SEA99M_V%sea99_vs(ilat+1,ilon,id1+i-1)-SEA99M_V%sea99_vs(ilat,ilon,id1+i-1)
+ dd1 = SEA99M_V%sea99_vs(ilat,ilon,id1+i-1) + yyy*xxx
+ yyy = SEA99M_V%sea99_vs(ilat+1,ilon+1,id1+i-1)-SEA99M_V%sea99_vs(ilat,ilon+1,id1+i-1)
+ dd2 = SEA99M_V%sea99_vs(ilat,ilon+1,id1+i-1) + yyy*xxx
+ xxx = (plo-alon1)/SEA99M_V%sea99_ddeg
+ yyy = dd2 - dd1
+ ddd(i) = dd1 + yyy*xxx
+ enddo
+ dvs = ddd(1) + (ddd(2)-ddd(1)) * xd1
+ if(dvs>1.d0) dvs=0.0d0
+
+end subroutine sea99_s_model
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sort_array_coordinates.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sort_array_coordinates.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sort_array_coordinates.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sort_array_coordinates.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,235 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! subroutines to sort MPI buffers to assemble between chunks
+
+ subroutine sort_array_coordinates(npointot,x,y,z,ibool,iglob,loc,ifseg,nglob,ind,ninseg,iwork,work)
+
+! this routine MUST be in double precision to avoid sensitivity
+! to roundoff errors in the coordinates of the points
+
+ implicit none
+
+ include "constants.h"
+
+ integer npointot,nglob
+
+ integer ibool(npointot),iglob(npointot),loc(npointot)
+ integer ind(npointot),ninseg(npointot)
+ logical ifseg(npointot)
+ double precision x(npointot),y(npointot),z(npointot)
+ integer iwork(npointot)
+ double precision work(npointot)
+
+ integer ipoin,i,j
+ integer nseg,ioff,iseg,ig
+ double precision xtol
+
+! establish initial pointers
+ do ipoin=1,npointot
+ loc(ipoin)=ipoin
+ enddo
+
+! define a tolerance, normalized radius is 1., so let's use a small value
+ xtol = SMALLVALTOL
+
+ ifseg(:)=.false.
+
+ nseg=1
+ ifseg(1)=.true.
+ ninseg(1)=npointot
+
+ do j=1,NDIM
+
+! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+
+ call rank_buffers(x(ioff),ind,ninseg(iseg))
+
+ else if(j == 2) then
+
+ call rank_buffers(y(ioff),ind,ninseg(iseg))
+
+ else
+
+ call rank_buffers(z(ioff),ind,ninseg(iseg))
+
+ endif
+
+ call swap_all_buffers(ibool(ioff),loc(ioff), &
+ x(ioff),y(ioff),z(ioff),iwork,work,ind,ninseg(iseg))
+
+ ioff=ioff+ninseg(iseg)
+ enddo
+
+! check for jumps in current coordinate
+ if(j == 1) then
+ do i=2,npointot
+ if(dabs(x(i)-x(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else if(j == 2) then
+ do i=2,npointot
+ if(dabs(y(i)-y(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else
+ do i=2,npointot
+ if(dabs(z(i)-z(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ endif
+
+! count up number of different segments
+ nseg=0
+ do i=1,npointot
+ if(ifseg(i)) then
+ nseg=nseg+1
+ ninseg(nseg)=1
+ else
+ ninseg(nseg)=ninseg(nseg)+1
+ endif
+ enddo
+ enddo
+
+! assign global node numbers (now sorted lexicographically)
+ ig=0
+ do i=1,npointot
+ if(ifseg(i)) ig=ig+1
+ iglob(loc(i))=ig
+ enddo
+
+ nglob=ig
+
+ end subroutine sort_array_coordinates
+
+! -------------------- library for sorting routine ------------------
+
+! sorting routines put here in same file to allow for inlining
+
+ subroutine rank_buffers(A,IND,N)
+!
+! Use Heap Sort (Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(n)
+ integer IND(n)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do j=1,n
+ IND(j)=j
+ enddo
+
+ if(n == 1) return
+
+ L=n/2+1
+ ir=n
+ 100 CONTINUE
+ IF(l>1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 CONTINUE
+ IF(J <= IR) THEN
+ IF(J < IR) THEN
+ IF(A(IND(j)) < A(IND(j+1))) j=j+1
+ ENDIF
+ IF (q < A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ goto 200
+ ENDIF
+ IND(I)=INDX
+ goto 100
+ end subroutine rank_buffers
+
+! -------------------------------------------------------------------
+
+ subroutine swap_all_buffers(IA,IB,A,B,C,IW,W,ind,n)
+!
+! swap arrays IA, IB, A, B and C according to addressing in array IND
+!
+ implicit none
+
+ integer n
+
+ integer IND(n)
+ integer IA(n),IB(n),IW(n)
+ double precision A(n),B(n),C(n),W(n)
+
+ integer i
+
+ do i=1,n
+ W(i)=A(i)
+ IW(i)=IA(i)
+ enddo
+
+ do i=1,n
+ A(i)=W(ind(i))
+ IA(i)=IW(ind(i))
+ enddo
+
+ do i=1,n
+ W(i)=B(i)
+ IW(i)=IB(i)
+ enddo
+
+ do i=1,n
+ B(i)=W(ind(i))
+ IB(i)=IW(ind(i))
+ enddo
+
+ do i=1,n
+ W(i)=C(i)
+ enddo
+
+ do i=1,n
+ C(i)=W(ind(i))
+ enddo
+
+ end subroutine swap_all_buffers
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,2627 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 Government Sponsorship Acknowledged.
+
+!! DK DK for the merged version
+ include 'call2.f90'
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+! include values created by the mesher
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+!=======================================================================!
+! !
+! specfem3D is a 3-D spectral-element solver for the Earth. !
+! It uses a mesh generated by program meshfem3D !
+! !
+!=======================================================================!
+!
+! 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 caltech.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+! Evolution of the code:
+! ---------------------
+!
+! 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, one more doubling level
+! at the bottom of the outer core, new inflated central cube
+! with optimized shape, far fewer mesh files saved by the mesher.
+! v. 3.6 Many people, many affiliations, September 2006:
+! adjoint and kernel calculations, 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
+! 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, 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 CM5
+!
+! From Dahlen and Tromp (1998):
+! ----------------------------
+!
+! Gravity is approximated by solving eq (3.259) without the Phi_E' term
+! The ellipsoidal reference model is that of section 14.1
+! The transversely isotropic expression for PREM is that of eq (8.190)
+!
+! Formulation in the fluid (acoustic) outer core:
+! -----------------------------------------------
+!
+! In case of an acoustic medium, a displacement potential Chi is used
+! as in Chaljub and Valette, Geophysical Journal International, vol. 158,
+! p. 131-141 (2004) and *NOT* a velocity potential as in Komatitsch and Tromp,
+! Geophysical Journal International, vol. 150, p. 303-318 (2002).
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement if we ignore gravity is then: u = grad(Chi)
+! (In the context of the Cowling approximation displacement is
+! u = grad(rho * Chi) / rho, *not* u = grad(Chi).)
+! Velocity is then: v = grad(Chi_dot) (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - rho * Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+! The source in an acoustic element is a pressure source.
+! The potential in the outer core is called displ_outer_core for simplicity.
+! Its first time derivative is called veloc_outer_core.
+! Its second time derivative is called accel_outer_core.
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: 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
+
+! 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
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: 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
+ integer nspec_iso,nspec_tiso,nspec_ani
+ 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, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
+ integer yr,jda,ho,mi
+ real(kind=CUSTOM_REAL) stf_used
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
+ double precision, dimension(:,:,:) ,allocatable:: nu_source
+ double precision sec,stf
+ double precision, dimension(:), allocatable :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision, dimension(:), allocatable :: xi_source,eta_source,gamma_source
+ double precision, dimension(:), allocatable :: t_cmt,hdur,hdur_gaussian
+ double precision, dimension(:), allocatable :: theta_source,phi_source
+ double precision, external :: comp_source_time_function
+ double precision t0
+
+! receiver information
+ integer nrec,nrec_local,nrec_tot_found,irec_local,ios
+ integer, dimension(:), allocatable :: islice_selected_rec,ispec_selected_rec,number_receiver_global
+ double precision, dimension(:), allocatable :: xi_receiver,eta_receiver,gamma_receiver
+ double precision hlagrange
+ character(len=150) :: STATIONS,rec_filename,dummystring
+ double precision, dimension(:,:,:), allocatable :: nu
+ double precision, allocatable, dimension(:) :: stlat,stlon,stele
+ character(len=MAX_LENGTH_STATION_NAME), dimension(:), allocatable :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(:), allocatable :: 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 !!!!!!!!!!!!!!!!!!!!!!,iproc,iproc_read
+ 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
+
+! 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
+
+ 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,LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, 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
+
+ character(len=150) prname
+
+! 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
+
+! flags to read kappa and mu and anisotropy arrays in regions where needed
+ logical READ_KAPPA_MU,READ_TISO
+
+! names of the data files for all the processors in MPI
+ character(len=150) outputname
+
+! if running on MareNostrum in Barcelona
+ character(len=400) system_command
+
+ 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_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+ logical :: CASE_3D
+
+! arrays for BCAST
+ integer, dimension(38) :: 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
+
+! ************** PROGRAM STARTS HERE **************
+
+! initialize the MPI communicator and start the NPROCTOT MPI processes.
+!! DK DK suppressed for merged version call MPI_INIT(ier)
+
+! sizeprocs returns number of processes started (should be equal to NPROCTOT).
+! myrank is the rank of each process, between 0 and sizeprocs-1.
+! as usual in MPI, process 0 is in charge of coordinating everything
+! and also takes care of the main output
+!! DK DK suppressed for merged version call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+!! DK DK suppressed for merged version call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+!! DK DK added this for merged version
+! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+!! 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
+ allocate(buffer_send_faces(NDIM_smaller_buffers,npoin2D_max_all),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_received_faces(NDIM_smaller_buffers,npoin2D_max_all),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ 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,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC_computed, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB_computed, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
+
+ if(err_occurred() /= 0) then
+ call exit_MPI(myrank,'an error occurred while reading the parameter file')
+ endif
+
+! 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/)
+
+ 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(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_integer,38,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(LOCAL_PATH,150,MPI_CHARACTER,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_region_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)
+
+ 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
+
+! if running on MareNostrum in Barcelona
+ if(RUN_ON_MARENOSTRUM_BARCELONA) then
+
+! check that we combine the seismograms in one large file to avoid GPFS overloading
+ if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) call exit_MPI(myrank,'should use SAVE_ALL_SEISMOS_IN_ONE_FILE for GPFS in Barcelona')
+
+! use the local scratch disk to save all the files, ignore the path that is given in the Par_file
+ LOCAL_PATH = '/scratch/komatits_new'
+
+! add processor name to local /scratch/komatits_new path
+ write(system_command,"('_proc',i4.4)") myrank
+ LOCAL_PATH = trim(LOCAL_PATH) // trim(system_command)
+
+ 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')
+
+ 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')
+
+!! DK DK added this
+ if(OCEANS) call exit_MPI(myrank,'DK DK je crois que j ai enleve les oceans par erreur, les remettre')
+
+! 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
+
+! start reading the databases
+
+! read arrays created by the mesher
+
+! crust and mantle
+
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+ READ_KAPPA_MU = .false.
+ READ_TISO = .false.
+ nspec_iso = 1
+ nspec_tiso = 1
+ nspec_ani = NSPEC_CRUST_MANTLE
+ else
+ nspec_iso = NSPEC_CRUST_MANTLE
+ if(TRANSVERSE_ISOTROPY_VAL) then
+ nspec_tiso = NSPECMAX_TISO_MANTLE
+ else
+ nspec_tiso = 1
+ endif
+ nspec_ani = 1
+ READ_KAPPA_MU = .true.
+ READ_TISO = .true.
+ endif
+
+! outer core (no anisotropy nor S velocity)
+! rmass_ocean_load is not used in this routine because it is meaningless in the outer core
+ READ_KAPPA_MU = .false.
+ READ_TISO = .false.
+ nspec_iso = NSPEC_OUTER_CORE
+ nspec_tiso = 1
+ nspec_ani = 1
+
+! inner core (no anisotropy)
+! rmass_ocean_load is not used in this routine because it is meaningless in the inner core
+ READ_KAPPA_MU = .true.
+ READ_TISO = .false.
+ nspec_iso = NSPEC_INNER_CORE
+ nspec_tiso = 1
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+ nspec_ani = NSPEC_INNER_CORE
+ else
+ nspec_ani = 1
+ endif
+
+! 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')
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! 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)
+
+! allocate arrays for source
+ allocate(islice_selected_source(NSOURCES),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(ispec_selected_source(NSOURCES),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(Mxx(NSOURCES),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(Myy(NSOURCES),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(Mzz(NSOURCES),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(Mxy(NSOURCES),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(Mxz(NSOURCES),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(Myz(NSOURCES),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(xi_source(NSOURCES),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(eta_source(NSOURCES),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(gamma_source(NSOURCES),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(t_cmt(NSOURCES),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(hdur(NSOURCES),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(hdur_gaussian(NSOURCES),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(theta_source(NSOURCES),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(phi_source(NSOURCES),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(nu_source(NDIM,NDIM,NSOURCES),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! 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)
+! 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)
+
+ 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')
+
+! allocate memory for receiver arrays
+ allocate(islice_selected_rec(nrec),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(ispec_selected_rec(nrec),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(xi_receiver(nrec),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(eta_receiver(nrec),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(gamma_receiver(nrec),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(station_name(nrec),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(network_name(nrec),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(stlat(nrec),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(stlon(nrec),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(stele(nrec),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(nu(NDIM,NDIM,nrec),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! 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)
+
+!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+! ---- source array
+
+ allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,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
+
+ 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
+
+! synchronize all the processes before assembling the mass matrix
+! to make sure all the nodes have finished to read their databases
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! 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 create_name_database(prname, myrank, IREGION_CRUST_MANTLE, LOCAL_PATH)
+ call get_attenuation_model_1D(myrank, prname, 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')
+ 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 *************
+! *********************************************************
+
+!! DK DK merged version: may set to 1 for timing
+! displ_crust_mantle = 1
+! veloc_crust_mantle = 1
+! displ_outer_core = 1
+! veloc_outer_core = 1
+! displ_inner_core = 1
+! veloc_inner_core = 1
+
+ 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
+
+ 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')
+
+ 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 < 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
+
+ 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
+
+ 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)
+ 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
+
+! if running on MareNostrum in Barcelona
+ if(RUN_ON_MARENOSTRUM_BARCELONA) then
+
+! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! suppress the local directory to leave space for future runs with a different rank number
+ write(system_command,"('rm -r -f /scratch/komatits_new_proc',i4.4)") myrank
+ call system(system_command)
+
+ endif
+
+! close the main output file
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of the simulation'
+ write(IMAIN,*)
+ close(IMAIN)
+ endif
+
+! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! stop all the MPI processes, and exit
+!! DK DK suppressed this for the merged version
+! call MPI_FINALIZE(ier)
+
+ end subroutine specfem3D
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/spline_routines.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/spline_routines.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/spline_routines.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/spline_routines.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,130 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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.
+!
+!=====================================================================
+
+! compute spline coefficients
+
+ subroutine spline_construction(xpoint,ypoint,npoint,tangent_first_point,tangent_last_point,spline_coefficients)
+
+ implicit none
+
+! tangent to the spline imposed at the first and last points
+ double precision, intent(in) :: tangent_first_point,tangent_last_point
+
+! number of input points and coordinates of the input points
+ integer, intent(in) :: npoint
+ double precision, dimension(npoint), intent(in) :: xpoint,ypoint
+
+! spline coefficients output by the routine
+ double precision, dimension(npoint), intent(out) :: spline_coefficients
+
+ integer :: i
+
+ double precision, dimension(:), allocatable :: temporary_array
+
+ allocate(temporary_array(npoint))
+
+ spline_coefficients(1) = - 1.d0 / 2.d0
+
+ temporary_array(1) = (3.d0/(xpoint(2)-xpoint(1)))*((ypoint(2)-ypoint(1))/(xpoint(2)-xpoint(1))-tangent_first_point)
+
+ do i = 2,npoint-1
+
+ spline_coefficients(i) = ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))-1.d0) &
+ / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
+
+ temporary_array(i) = (6.d0*((ypoint(i+1)-ypoint(i))/(xpoint(i+1)-xpoint(i)) &
+ - (ypoint(i)-ypoint(i-1))/(xpoint(i)-xpoint(i-1)))/(xpoint(i+1)-xpoint(i-1)) &
+ - (xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*temporary_array(i-1)) &
+ / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
+
+ enddo
+
+ spline_coefficients(npoint) = ((3.d0/(xpoint(npoint)-xpoint(npoint-1))) &
+ * (tangent_last_point-(ypoint(npoint)-ypoint(npoint-1))/(xpoint(npoint)-xpoint(npoint-1))) &
+ - 1.d0/2.d0*temporary_array(npoint-1))/(1.d0/2.d0*spline_coefficients(npoint-1)+1.d0)
+
+ do i = npoint-1,1,-1
+ spline_coefficients(i) = spline_coefficients(i)*spline_coefficients(i+1) + temporary_array(i)
+ enddo
+
+ deallocate(temporary_array)
+
+ end subroutine spline_construction
+
+! --------------
+
+! evaluate a spline
+
+ subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate_spline,y_spline_obtained)
+
+ implicit none
+
+! number of input points and coordinates of the input points
+ integer, intent(in) :: npoint
+ double precision, dimension(npoint), intent(in) :: xpoint,ypoint
+
+! spline coefficients to use
+ double precision, dimension(npoint), intent(in) :: spline_coefficients
+
+! abscissa at which we need to evaluate the value of the spline
+ double precision, intent(in):: x_evaluate_spline
+
+! ordinate evaluated by the routine for the spline at this abscissa
+ double precision, intent(out):: y_spline_obtained
+
+ integer :: index_loop,index_lower,index_higher
+
+ double precision :: coef1,coef2
+
+! initialize to the whole interval
+ index_lower = 1
+ index_higher = npoint
+
+! determine the right interval to use, by dichotomy
+ do while (index_higher - index_lower > 1)
+! compute the middle of the interval
+ index_loop = (index_higher + index_lower) / 2
+ if(xpoint(index_loop) > x_evaluate_spline) then
+ index_higher = index_loop
+ else
+ index_lower = index_loop
+ endif
+ enddo
+
+! test that the interval obtained does not have a size of zero
+! (this could happen for instance in the case of duplicates in the input list of points)
+ if(xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation'
+
+ coef1 = (xpoint(index_higher) - x_evaluate_spline) / (xpoint(index_higher) - xpoint(index_lower))
+ coef2 = (x_evaluate_spline - xpoint(index_lower)) / (xpoint(index_higher) - xpoint(index_lower))
+
+ y_spline_obtained = coef1*ypoint(index_lower) + coef2*ypoint(index_higher) + &
+ ((coef1**3 - coef1)*spline_coefficients(index_lower) + &
+ (coef2**3 - coef2)*spline_coefficients(index_higher))*((xpoint(index_higher) - xpoint(index_lower))**2)/6.d0
+
+ end subroutine spline_evaluation
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/store_xelm_yelm_zelm.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/store_xelm_yelm_zelm.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/store_xelm_yelm_zelm.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/store_xelm_yelm_zelm.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,14 @@
+
+!! DK DK added for merged version
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ xelm_store(:,ispec) = sngl(xelm(:))
+ yelm_store(:,ispec) = sngl(yelm(:))
+ zelm_store(:,ispec) = sngl(zelm(:))
+ else
+ xelm_store(:,ispec) = xelm(:)
+ yelm_store(:,ispec) = yelm(:)
+ zelm_store(:,ispec) = zelm(:)
+ endif
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/stretching_function.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/stretching_function.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/stretching_function.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/stretching_function.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,75 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 stretching_function(r_top,r_bottom,ner,stretch_tab)
+
+! define stretch_tab which contains r_top and r_bottom for each element layer in the crust for 3D models.
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: r_top, r_bottom,value
+ integer :: ner,i
+ double precision, dimension (2,ner) :: stretch_tab
+! for increasing execution speed but have less precision in stretching, increase step
+! not very effective algorithm, but sufficient : used once per proc for meshing.
+ double precision, parameter :: step = 0.001
+
+! initialize array
+ do i=1,ner
+ stretch_tab(2,i)=(1.d0/ner)
+ enddo
+
+! fill with ratio of the layer one thickness for each element
+ do while((stretch_tab(2,1) / stretch_tab(2,ner)) > MAX_RATIO_CRUST_STRETCHING)
+ if (modulo(ner,2) /= 0) then
+ value = -floor(ner/2.d0)*step
+ else
+ value = (0.5d0-floor(ner/2.d0))*step
+ endif
+ do i=1,ner
+ stretch_tab(2,i) = stretch_tab(2,i) + value
+ value = value + step
+ enddo
+ enddo
+
+! deduce r_top and r_bottom
+ ! r_top
+ stretch_tab(1,1) = r_top
+ do i=2,ner
+ stretch_tab(1,i) = sum(stretch_tab(2,i:ner))*(r_top-r_bottom) + r_bottom
+ enddo
+
+ ! r_bottom
+ stretch_tab(2,ner) = r_bottom
+ do i=1,ner-1
+ stretch_tab(2,i) = stretch_tab(1,i+1)
+ enddo
+
+end subroutine stretching_function
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/topo_bathy.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/topo_bathy.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/topo_bathy.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/topo_bathy.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,106 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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 get_topo_bathy(xlat,xlon,value,ibathy_topo)
+
+!
+!---- get elevation or ocean depth in meters at a given latitude and longitude
+!
+
+ implicit none
+
+ include "constants.h"
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ double precision xlat,xlon,value
+
+ integer iadd1,iel1
+ double precision samples_per_degree_topo
+ double precision xlo
+
+ xlo = xlon
+ if(xlon < 0.d0) xlo = xlo + 360.d0
+
+! compute number of samples per degree
+ samples_per_degree_topo = dble(RESOLUTION_TOPO_FILE) / 60.d0
+
+! compute offset in data file and avoid edge effects
+ iadd1 = 1 + int((90.d0-xlat)/samples_per_degree_topo)
+ if(iadd1 < 1) iadd1 = 1
+ if(iadd1 > NY_BATHY) iadd1 = NY_BATHY
+
+ iel1 = int(xlo/samples_per_degree_topo)
+ if(iel1 <= 0 .or. iel1 > NX_BATHY) iel1 = NX_BATHY
+
+! convert integer value to double precision
+ value = dble(ibathy_topo(iel1,iadd1))
+
+ end subroutine get_topo_bathy
+
+! -------------------------------------------
+
+ subroutine read_topo_bathy_file(ibathy_topo)
+!
+!---- read topography and bathymetry file once and for all
+!
+ implicit none
+
+ include "constants.h"
+
+ character(len=150) topo_bathy_file
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ integer itopo_x,itopo_y
+
+ call get_value_string(topo_bathy_file, 'model.topoBathy.PATHNAME_TOPO_FILE', PATHNAME_TOPO_FILE)
+
+ open(unit=13,file=topo_bathy_file,status='old',action='read')
+
+ do itopo_y=1,NY_BATHY
+ do itopo_x=1,NX_BATHY
+
+ read(13,*) ibathy_topo(itopo_x,itopo_y)
+
+! impose maximum height of mountains, to suppress oscillations in Himalaya etc.
+ if(USE_MAXIMUM_HEIGHT_TOPO .and. ibathy_topo(itopo_x,itopo_y) > MAXIMUM_HEIGHT_TOPO) &
+ ibathy_topo(itopo_x,itopo_y) = MAXIMUM_HEIGHT_TOPO
+
+! impose maximum depth of oceans, to suppress oscillations near deep trenches
+ if(USE_MAXIMUM_DEPTH_OCEANS .and. ibathy_topo(itopo_x,itopo_y) < MAXIMUM_DEPTH_OCEANS) &
+ ibathy_topo(itopo_x,itopo_y) = MAXIMUM_DEPTH_OCEANS
+
+ enddo
+ enddo
+
+ close(13)
+
+ end subroutine read_topo_bathy_file
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.f90 (from rev 11994, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/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-05-22 18:29:40 UTC (rev 12002)
@@ -0,0 +1,688 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! 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
+! February 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)
+
+ 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(:,:), allocatable :: 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
+
+ allocate(one_seismogram(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
+ if(ier /= 0) stop 'error while allocating one temporary seismogram'
+
+! 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')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
+ form='unformatted',position='append')
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='old',&
+ form='formatted',position='append')
+ 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')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
+ form='unformatted',position='append')
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='old',&
+ form='formatted',position='append')
+ 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
+
+ deallocate(one_seismogram)
+
+ 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) ! 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')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2),status='old',position='append')
+ 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/store_xelm_yelm_zelm.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/store_xelm_yelm_zelm.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/store_xelm_yelm_zelm.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,14 +0,0 @@
-
-!! DK DK added for merged version
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- xelm_store(:,ispec) = sngl(xelm(:))
- yelm_store(:,ispec) = sngl(yelm(:))
- zelm_store(:,ispec) = sngl(zelm(:))
- else
- xelm_store(:,ispec) = xelm(:)
- yelm_store(:,ispec) = yelm(:)
- zelm_store(:,ispec) = zelm(:)
- endif
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/stretching_function.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/stretching_function.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/stretching_function.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,75 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 stretching_function(r_top,r_bottom,ner,stretch_tab)
-
-! define stretch_tab which contains r_top and r_bottom for each element layer in the crust for 3D models.
-
- implicit none
-
- include "constants.h"
-
- double precision :: r_top, r_bottom,value
- integer :: ner,i
- double precision, dimension (2,ner) :: stretch_tab
-! for increasing execution speed but have less precision in stretching, increase step
-! not very effective algorithm, but sufficient : used once per proc for meshing.
- double precision, parameter :: step = 0.001
-
-! initialize array
- do i=1,ner
- stretch_tab(2,i)=(1.d0/ner)
- enddo
-
-! fill with ratio of the layer one thickness for each element
- do while((stretch_tab(2,1) / stretch_tab(2,ner)) > MAX_RATIO_CRUST_STRETCHING)
- if (modulo(ner,2) /= 0) then
- value = -floor(ner/2.d0)*step
- else
- value = (0.5d0-floor(ner/2.d0))*step
- endif
- do i=1,ner
- stretch_tab(2,i) = stretch_tab(2,i) + value
- value = value + step
- enddo
- enddo
-
-! deduce r_top and r_bottom
- ! r_top
- stretch_tab(1,1) = r_top
- do i=2,ner
- stretch_tab(1,i) = sum(stretch_tab(2,i:ner))*(r_top-r_bottom) + r_bottom
- enddo
-
- ! r_bottom
- stretch_tab(2,ner) = r_bottom
- do i=1,ner-1
- stretch_tab(2,i) = stretch_tab(1,i+1)
- enddo
-
-end subroutine stretching_function
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/topo_bathy.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/topo_bathy.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/topo_bathy.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,106 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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 get_topo_bathy(xlat,xlon,value,ibathy_topo)
-
-!
-!---- get elevation or ocean depth in meters at a given latitude and longitude
-!
-
- implicit none
-
- include "constants.h"
-
-! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
- double precision xlat,xlon,value
-
- integer iadd1,iel1
- double precision samples_per_degree_topo
- double precision xlo
-
- xlo = xlon
- if(xlon < 0.d0) xlo = xlo + 360.d0
-
-! compute number of samples per degree
- samples_per_degree_topo = dble(RESOLUTION_TOPO_FILE) / 60.d0
-
-! compute offset in data file and avoid edge effects
- iadd1 = 1 + int((90.d0-xlat)/samples_per_degree_topo)
- if(iadd1 < 1) iadd1 = 1
- if(iadd1 > NY_BATHY) iadd1 = NY_BATHY
-
- iel1 = int(xlo/samples_per_degree_topo)
- if(iel1 <= 0 .or. iel1 > NX_BATHY) iel1 = NX_BATHY
-
-! convert integer value to double precision
- value = dble(ibathy_topo(iel1,iadd1))
-
- end subroutine get_topo_bathy
-
-! -------------------------------------------
-
- subroutine read_topo_bathy_file(ibathy_topo)
-!
-!---- read topography and bathymetry file once and for all
-!
- implicit none
-
- include "constants.h"
-
- character(len=150) topo_bathy_file
-
-! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
- integer itopo_x,itopo_y
-
- call get_value_string(topo_bathy_file, 'model.topoBathy.PATHNAME_TOPO_FILE', PATHNAME_TOPO_FILE)
-
- open(unit=13,file=topo_bathy_file,status='old',action='read')
-
- do itopo_y=1,NY_BATHY
- do itopo_x=1,NX_BATHY
-
- read(13,*) ibathy_topo(itopo_x,itopo_y)
-
-! impose maximum height of mountains, to suppress oscillations in Himalaya etc.
- if(USE_MAXIMUM_HEIGHT_TOPO .and. ibathy_topo(itopo_x,itopo_y) > MAXIMUM_HEIGHT_TOPO) &
- ibathy_topo(itopo_x,itopo_y) = MAXIMUM_HEIGHT_TOPO
-
-! impose maximum depth of oceans, to suppress oscillations near deep trenches
- if(USE_MAXIMUM_DEPTH_OCEANS .and. ibathy_topo(itopo_x,itopo_y) < MAXIMUM_DEPTH_OCEANS) &
- ibathy_topo(itopo_x,itopo_y) = MAXIMUM_DEPTH_OCEANS
-
- enddo
- enddo
-
- close(13)
-
- end subroutine read_topo_bathy_file
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/write_seismograms.f90 2008-05-22 18:20:28 UTC (rev 12001)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/write_seismograms.f90 2008-05-22 18:29:40 UTC (rev 12002)
@@ -1,688 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
-! --------------------------------------------------
-!
-! 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
-! February 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)
-
- 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(:,:), allocatable :: 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
-
- allocate(one_seismogram(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
- if(ier /= 0) stop 'error while allocating one temporary seismogram'
-
-! 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')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
- form='unformatted',position='append')
- endif
- else
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='old',&
- form='formatted',position='append')
- 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')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
- form='unformatted',position='append')
- endif
- else
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='old',&
- form='formatted',position='append')
- 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
-
- deallocate(one_seismogram)
-
- 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) ! 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')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2),status='old',position='append')
- 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