[cig-commits] r17978 - in seismo/3D/SPECFEM3D_GLOBE/trunk: . setup src
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Fri Feb 25 14:36:22 PST 2011
Author: dkomati1
Date: 2011-02-25 14:36:07 -0800 (Fri, 25 Feb 2011)
New Revision: 17978
Added:
seismo/3D/SPECFEM3D_GLOBE/trunk/setup/config.h.in
seismo/3D/SPECFEM3D_GLOBE/trunk/setup/constants.h.in
seismo/3D/SPECFEM3D_GLOBE/trunk/setup/precision.h.in
seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_missing_nodes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_410_650.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_cmb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_icb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_central_cube_block.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_scalar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_scalar_block.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_vector.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_vector_block.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/auto_ner.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/broadcast_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/calc_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/calendar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_1D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_2D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_corners_chunks.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_faces_chunks.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_simulation_stability.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_AVS_DX.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_paraview_strain_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_surf_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_vol_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/comp_source_spectrum.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/comp_source_time_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_add_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_arrays_source.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_boundary_kernel.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_coordinates_grid.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_coupling.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_element_properties.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_crust_mantle_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_inner_core_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_outer_core_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_seismograms.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_stacey_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_stacey_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/convert_time.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/convolve_source_timefunction.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/count_number_of_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_central_cube_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_chunk_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_doubling_elements.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_mass_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_movie_AVS_DX.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_movie_GMT_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_name_database.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_regions_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_regular_elements.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_serial_name_database.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/define_derivation_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/define_superbrick.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/euler_angles.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/exit_mpi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/fix_non_blocking_flags.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_1D_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_cutplanes_eta.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_cutplanes_xi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_absorb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_attenuation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_backazimuth.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_cmt.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_event_info.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_jacobian_discontinuities.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_model_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_shape2D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_shape3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_value_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/gll_library.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/hex_nodes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/initialize_simulation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/intgrl.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/lagrange_poly.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/lgndr.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/locate_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/locate_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/make_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/make_gravity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/memory_eval.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D_models.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_1066a.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_1dref.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_ak135.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_aniso_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_aniso_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_atten3D_QRFSI12.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_attenuation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_crust.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_crustmaps.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_eucrust.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_gapp2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_gll.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_heterogen_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_iasp91.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_jp1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_jp3d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_ppm.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_prem.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_s20rts.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_s362ani.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_s40rts.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_sea1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_sea99_s.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_topo_bathy.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/netlib_specfun_erf.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/noise_tomography.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/param_reader.c
seismo/3D/SPECFEM3D_GLOBE/trunk/src/prepare_timerun.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_arrays_buffers_solver.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_mesh_databases.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_parameter_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_value_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/recompute_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/reduce.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/rthetaphi_xyz.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/setup_sources_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/sort_array_coordinates.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/spline_routines.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/stretching_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_chunks_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_faces_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_surface_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_c_binary.c
seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_movie_surface.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_movie_volume.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_output_ASCII.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_output_SAC.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_seismograms.f90
Removed:
seismo/3D/SPECFEM3D_GLOBE/trunk/add_missing_nodes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_410_650.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_cmb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_icb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_central_cube_block.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_scalar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_scalar_block.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_vector.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_vector_block.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/auto_ner.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/broadcast_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/calc_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/calendar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_1D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_2D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_corners_chunks.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_faces_chunks.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/check_simulation_stability.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/combine_AVS_DX.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/combine_paraview_strain_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/combine_surf_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/combine_vol_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/comp_source_spectrum.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/comp_source_time_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_add_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_arrays_source.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_boundary_kernel.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coordinates_grid.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coupling.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_element_properties.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_seismograms.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/config.h.in
seismo/3D/SPECFEM3D_GLOBE/trunk/constants.h.in
seismo/3D/SPECFEM3D_GLOBE/trunk/convert_time.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/convolve_source_timefunction.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/count_number_of_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_chunk_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_doubling_elements.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_mass_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_AVS_DX.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_GMT_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_name_database.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_regions_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_regular_elements.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_serial_name_database.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/define_derivation_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/define_superbrick.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/euler_angles.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/exit_mpi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/fix_non_blocking_flags.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_1D_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_eta.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_xi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_absorb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_attenuation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_backazimuth.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_cmt.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_event_info.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_discontinuities.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_model_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_shape2D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_shape3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_value_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/gll_library.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/hex_nodes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/initialize_simulation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/intgrl.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/lagrange_poly.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/lgndr.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/locate_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/locate_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/make_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/make_gravity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/memory_eval.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D_models.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_1066a.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_1dref.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_ak135.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_atten3D_QRFSI12.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_attenuation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_crust.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_crustmaps.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_eucrust.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_gapp2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_gll.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_heterogen_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_iasp91.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp3d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_ppm.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_prem.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_s20rts.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_s362ani.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_s40rts.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea99_s.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_topo_bathy.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/netlib_specfun_erf.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/noise_tomography.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/param_reader.c
seismo/3D/SPECFEM3D_GLOBE/trunk/precision.h.in
seismo/3D/SPECFEM3D_GLOBE/trunk/prepare_timerun.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_arrays_buffers_solver.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_mesh_databases.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_parameter_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_value_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/recompute_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/reduce.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/rthetaphi_xyz.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/save_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/save_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/save_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/save_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/setup_sources_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/sort_array_coordinates.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/specfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/spline_routines.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/stretching_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_chunks_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_faces_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_surface_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_c_binary.c
seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_surface.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_volume.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_output_ASCII.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_output_SAC.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_seismograms.f90
Log:
moved all the source files to the new "src" directory and all the setup files to the new "setup" directory
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/add_missing_nodes.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/add_missing_nodes.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/add_missing_nodes.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! compute the 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 UTILS/chunk_notes_scanned/numbering_convention_27_nodes.tif
-
- 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 UTILS/chunk_notes_scanned/numbering_convention_27_nodes.tif
-
- 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/add_topography.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,172 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- !> Hejun
- ! This subroutine uses GLL points to capture topography variation rather
- ! than using control nodes
- ! Hejun Zhu, OCT16, 2009
-
- ! input parameters: myrank,
- ! xstore,ystore,zstore,
- ! ispec,nspec,
- ! ibathy_topo
- ! R220
-
- subroutine add_topography_gll(myrank,xstore,ystore,zstore,ispec,nspec,&
- ibathy_topo,R220)
-
- implicit none
-
- include "constants.h"
-
- ! input parameters
- integer:: myrank
- integer:: ispec,nspec
- double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec):: xstore,ystore,zstore
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
- double precision:: R220
-
- ! local parameters used in this subroutine
- integer:: i,j,k
- double precision:: r,theta,phi,colat
- double precision:: lat,lon,elevation,gamma
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- ! convert to r theta phi
- ! slightly move points to avoid roundoff problem when exactly on the polar axis
- call xyz_2_rthetaphi_dble(xstore(i,j,k,ispec),ystore(i,j,k,ispec),zstore(i,j,k,ispec),&
- 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 factor makes sense
- if(gamma < -0.02 .or. gamma > 1.02) then
- call exit_MPI(myrank,'incorrect value of factor for topography gll points')
- end if
- !
-
- ! since not all GLL points are exactlly at R220, use a small
- ! tolerance for R220 detection
- if (abs(gamma) < SMALLVAL) then
- gamma = 0.0
- end if
- xstore(i,j,k,ispec) = xstore(i,j,k,ispec)*(ONE + gamma * elevation / r)
- ystore(i,j,k,ispec) = ystore(i,j,k,ispec)*(ONE + gamma * elevation / r)
- zstore(i,j,k,ispec) = zstore(i,j,k,ispec)*(ONE + gamma * elevation / r)
-
- end do
- end do
- end do
- end subroutine add_topography_gll
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_410_650.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_410_650.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_410_650.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,249 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- !> Hejun
- ! use GLL points to capture 410_650 topography
- ! JAN08, 2010
- subroutine add_topography_410_650_gll(myrank,xstore,ystore,zstore,ispec,nspec,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
- integer:: ispec,nspec
- double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec):: xstore,ystore,zstore
-
- double precision R220,R400,R670,R771
-
- integer i,j,k
-
- 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 GLL points of the element
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- ! convert to r theta phi
- call xyz_2_rthetaphi_dble(xstore(i,j,k,ispec),ystore(i,j,k,ispec),zstore(i,j,k,ispec),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)
- xstore(i,j,k,ispec) = xstore(i,j,k,ispec)*(ONE + gamma * topo410 / r)
- ystore(i,j,k,ispec) = ystore(i,j,k,ispec)*(ONE + gamma * topo410 / r)
- zstore(i,j,k,ispec) = zstore(i,j,k,ispec)*(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)
- xstore(i,j,k,ispec) = xstore(i,j,k,ispec)*(ONE + gamma * topo650 / r)
- ystore(i,j,k,ispec) = ystore(i,j,k,ispec)*(ONE + gamma * topo650 / r)
- zstore(i,j,k,ispec) = zstore(i,j,k,ispec)*(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)
- xstore(i,j,k,ispec) = xstore(i,j,k,ispec)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
- ystore(i,j,k,ispec) = ystore(i,j,k,ispec)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
- zstore(i,j,k,ispec) = zstore(i,j,k,ispec)*(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 do
- end do
-
- end subroutine add_topography_410_650_gll
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_cmb.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_cmb.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_cmb.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/add_topography_icb.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_icb.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_icb.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/assemble_MPI_central_cube.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_central_cube.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_central_cube.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,328 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM_INNER_CORE,vector_assemble,ndim_assemble,iphase_CC)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
- include 'constants.h'
-
-! include values created by the mesher
- include "OUTPUT_FILES/values_from_mesher.h"
-
-! for matching with central cube in inner core
- integer, intent(in) :: ichunk, nb_msgs_theor_in_cube, npoin2D_cube_from_slices
- integer, intent(inout) :: iphase_CC
- integer, dimension(nb_msgs_theor_in_cube), intent(in) :: sender_from_slices_to_cube
- double precision, dimension(npoin2D_cube_from_slices,ndim_assemble), intent(inout) :: buffer_slices
- double precision, dimension(npoin2D_cube_from_slices,ndim_assemble,nb_msgs_theor_in_cube), intent(inout) :: &
- buffer_all_cube_from_slices
- integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices), intent(in) :: ibool_central_cube
- integer, intent(in) :: receiver_cube_from_slices
-
-! local to global mapping
- integer, intent(in) :: NSPEC2D_BOTTOM_INNER_CORE
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE), intent(in) :: ibool_inner_core
- integer, dimension(NSPEC_INNER_CORE), intent(in) :: idoubling_inner_core
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE), intent(in) :: ibelm_bottom_inner_core
-
-! vector
- integer, intent(in) :: ndim_assemble
- real(kind=CUSTOM_REAL), dimension(ndim_assemble,NGLOB_INNER_CORE), intent(inout) :: 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, save :: request_send,request_receive
-! maximum value of nb_msgs_theor_in_cube is 5 (when NPROC_XI == 1)
-! therefore NPROC_XI+4 is always large enough
- integer, dimension(NPROC_XI_VAL+4), save :: request_send_array,request_receive_array
- logical :: flag_result_test
- integer, dimension(MPI_STATUS_SIZE) :: msg_status
- integer :: ier
-
-! mask
- logical, dimension(NGLOB_INNER_CORE) :: mask
-
-!---
-!--- use buffers to assemble mass matrix with central cube once and for all
-!---
-
- if(iphase_CC == 1) then
-
-! 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_IRECV(buffer_all_cube_from_slices(:,:,imsg), &
- ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
- itag,MPI_COMM_WORLD,request_receive_array(imsg),ier)
- 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,:) = 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_ISSEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
- MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,request_send,ier)
- endif ! end sending info to central cube
-
- iphase_CC = iphase_CC + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase_CC 1
-
- if(iphase_CC == 2) then
-
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
- call MPI_TEST(request_send,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- endif
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
- do imsg = 1,nb_msgs_theor_in_cube-1
- call MPI_TEST(request_receive_array(imsg),flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
- enddo
- endif
-
-! 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,:) = 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)
-
- call MPI_IRECV(buffer_all_cube_from_slices(:,:,nb_msgs_theor_in_cube), &
- ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender,itag,MPI_COMM_WORLD,request_receive,ier)
-!! DK DK this merged with previous statement
-! buffer_all_cube_from_slices(:,:,nb_msgs_theor_in_cube) = buffer_slices2(:,:)
-
- call MPI_ISSEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,receiver_cube_from_slices, &
- itag,MPI_COMM_WORLD,request_send,ier)
- endif
-
- iphase_CC = iphase_CC + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase_CC 2
-
- if(iphase_CC == 3) then
-
-!--- now we need to assemble the contributions
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- call MPI_TEST(request_send,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
-
- 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(ipoin,idimension,imsg))
- else
- array_central_cube(ibool_central_cube(imsg,ipoin)) = buffer_all_cube_from_slices(ipoin,idimension,imsg)
- 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(ipoin,idimension,nb_msgs_theor_in_cube))
- 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(ipoin,idimension,nb_msgs_theor_in_cube)
- 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(ipoin,idimension,imsg) = 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_IRECV(buffer_slices, &
- ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
- itag,MPI_COMM_WORLD,request_receive,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(:,ibool_inner_core(i,j,k,ispec)) = sngl(buffer_slices(ipoin,:))
-! else
-! vector_assemble(:,ibool_inner_core(i,j,k,ispec)) = buffer_slices(ipoin,:)
-! 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
-! send buffers to slices
- receiver = sender_from_slices_to_cube(imsg)
- call MPI_ISSEND(buffer_all_cube_from_slices(:,:,imsg),ndim_assemble*npoin2D_cube_from_slices, &
- MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,request_send_array(imsg),ier)
- enddo
- endif
-
- iphase_CC = iphase_CC + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase_CC 3
-
- if(iphase_CC == 4) then
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
- do imsg = 1,nb_msgs_theor_in_cube-1
- call MPI_TEST(request_send_array(imsg),flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- enddo
- endif
-
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
- call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
- 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
-! 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,:))
- else
- vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)) = buffer_slices(ipoin,:)
- endif
- enddo
- enddo
- enddo
- endif ! end receiving info from central cube
-
-! this is the exit condition, to go beyond the last phase number
- iphase_CC = iphase_CC + 1
-
- endif !!!!!!!!! end of iphase_CC 4
-
- end subroutine assemble_MPI_central_cube
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_central_cube_block.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_central_cube_block.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_central_cube_block.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,263 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-subroutine assemble_MPI_central_cube_block(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)
-
-! this version of the routine is based on blocking MPI calls
-
- 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_block
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_scalar.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_scalar.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_scalar.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,574 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!----
-!---- 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, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NCHUNKS,iphase)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
- integer myrank,nglob,NCHUNKS,iphase
-
-! array to assemble
- real(kind=CUSTOM_REAL), dimension(nglob), intent(inout) :: array_val
-
- integer, intent(in) :: iproc_xi,iproc_eta,ichunk
- integer, dimension(NB_SQUARE_EDGES_ONEDIR), intent(in) :: npoin2D_xi,npoin2D_eta
- integer, intent(in) :: npoin2D_faces(NUMFACES_SHARED)
-
- integer, intent(in) :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY
- integer, intent(in) :: NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL
- integer, intent(in) :: NUMMSGS_FACES,NCORNERSCHUNKS
-
-! for addressing of the slices
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1), intent(in) :: addressing
-
-! 2-D addressing and buffers for summation between slices
- integer, dimension(NGLOB2DMAX_XMIN_XMAX), intent(in) :: iboolleft_xi,iboolright_xi
- integer, dimension(NGLOB2DMAX_YMIN_YMAX), intent(in) :: iboolleft_eta,iboolright_eta
-
-! indirect addressing for each corner of the chunks
- integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED), intent(in) :: iboolcorner
- integer icount_corners
-
- integer, intent(in) :: npoin2D_max_all_CM_IC
- integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED), intent(in) :: iboolfaces
- real(kind=CUSTOM_REAL), dimension(npoin2D_max_all_CM_IC,NUMFACES_SHARED), intent(inout) :: 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), intent(inout) :: buffer_send_chunkcorn_scalar, &
- buffer_recv_chunkcorn_scalar
-
-! ---- arrays to assemble between chunks
-
-! communication pattern for faces between chunks
- integer, dimension(NUMMSGS_FACES), intent(in) :: iprocfrom_faces,iprocto_faces
-
-! communication pattern for corners between chunks
- integer, dimension(NCORNERSCHUNKS), intent(in) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
-! MPI status of messages to be received
- integer, dimension(MPI_STATUS_SIZE) :: msg_status
-
- integer :: ipoin,ipoin2D,ipoin1D
- integer :: sender,receiver
- integer :: imsg
- integer :: icount_faces,npoin2D_chunks
-
- integer :: ier
-! do not remove the "save" statement because this routine is non blocking
- integer, save :: request_send,request_receive
- integer, dimension(NUMFACES_SHARED), save :: request_send_array,request_receive_array
- logical :: flag_result_test
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! check flag to see if we need to assemble (might be turned off when debugging)
- if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) then
- iphase = 9999 ! this means everything is finished
- return
- endif
-
-! 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
-!----
-
- if(iphase == 1) then
-
-! slices copy the right face into the buffer
- do ipoin=1,npoin2D_xi(2)
- buffer_send_faces_scalar(ipoin,1) = 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_IRECV(buffer_received_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive,ier)
-
- call MPI_ISSEND(buffer_send_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,receiver, &
- itag2,MPI_COMM_WORLD,request_send,ier)
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 1
-
- if(iphase == 2) then
-
-! call MPI_WAIT(request_send,msg_status,ier)
-! call MPI_WAIT(request_receive,msg_status,ier)
- call MPI_TEST(request_send,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
-
-! 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,1)
- 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,1) = 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_IRECV(buffer_received_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive,ier)
-
- call MPI_ISSEND(buffer_send_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,receiver, &
- itag2,MPI_COMM_WORLD,request_send,ier)
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 2
-
- if(iphase == 3) then
-
-! call MPI_WAIT(request_send,msg_status,ier)
-! call MPI_WAIT(request_receive,msg_status,ier)
- call MPI_TEST(request_send,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
-
-! 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,1)
- enddo
- endif
-
-!----
-!---- then assemble along eta using the 2-D topology
-!----
-
-! slices copy the right face into the buffer
- do ipoin=1,npoin2D_eta(2)
- buffer_send_faces_scalar(ipoin,1) = 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_IRECV(buffer_received_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive,ier)
-
- call MPI_ISSEND(buffer_send_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,receiver, &
- itag2,MPI_COMM_WORLD,request_send,ier)
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 3
-
- if(iphase == 4) then
-
-! call MPI_WAIT(request_send,msg_status,ier)
-! call MPI_WAIT(request_receive,msg_status,ier)
- call MPI_TEST(request_send,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
-
-! 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,1)
- 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,1) = 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_IRECV(buffer_received_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive,ier)
-
- call MPI_ISSEND(buffer_send_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,receiver, &
- itag2,MPI_COMM_WORLD,request_send,ier)
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 4
-
- if(iphase == 5) then
-
-! call MPI_WAIT(request_send,msg_status,ier)
-! call MPI_WAIT(request_receive,msg_status,ier)
- call MPI_TEST(request_send,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
-
-! 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,1)
- enddo
- 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) then
- iphase = 9999 ! this means everything is finished
- return
- endif
-
-! ***************************************************************
-! transmit messages in forward direction (iprocfrom -> iprocto)
-! ***************************************************************
-
-!---- 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==iprocto_faces(imsg)) then
- sender = iprocfrom_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- call MPI_IRECV(buffer_received_faces_scalar(:,icount_faces), &
- npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive_array(icount_faces),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)) then
- receiver = iprocto_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- do ipoin2D=1,npoin2D_chunks
- buffer_send_faces_scalar(ipoin2D,icount_faces) = array_val(iboolfaces(ipoin2D,icount_faces))
- enddo
- call MPI_ISSEND(buffer_send_faces_scalar(:,icount_faces),npoin2D_chunks, &
- CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,request_send_array(icount_faces),ier)
- endif
- enddo
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 5
-
- if(iphase == 6) then
-
- 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)) then
- call MPI_TEST(request_receive_array(icount_faces),flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
- endif
- enddo
-
- 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)) then
- call MPI_TEST(request_send_array(icount_faces),flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- endif
- enddo
-
- 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)) then
- do ipoin2D=1,npoin2D_faces(icount_faces)
- array_val(iboolfaces(ipoin2D,icount_faces)) = &
- array_val(iboolfaces(ipoin2D,icount_faces)) + buffer_received_faces_scalar(ipoin2D,icount_faces)
- enddo
- 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)) then
- sender = iprocto_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- call MPI_IRECV(buffer_received_faces_scalar(:,icount_faces), &
- npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive_array(icount_faces),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)) then
- receiver = iprocfrom_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- do ipoin2D=1,npoin2D_chunks
- buffer_send_faces_scalar(ipoin2D,icount_faces) = array_val(iboolfaces(ipoin2D,icount_faces))
- enddo
- call MPI_ISSEND(buffer_send_faces_scalar(:,icount_faces),npoin2D_chunks, &
- CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,request_send_array(icount_faces),ier)
- endif
- enddo
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 6
-
- if(iphase == 7) then
-
- 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)) then
- call MPI_TEST(request_send_array(icount_faces),flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
- endif
- enddo
-
- 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)) then
- call MPI_TEST(request_receive_array(icount_faces),flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- endif
- enddo
-
- 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)) then
- do ipoin2D=1,npoin2D_faces(icount_faces)
- array_val(iboolfaces(ipoin2D,icount_faces)) = buffer_received_faces_scalar(ipoin2D,icount_faces)
- enddo
- endif
- enddo
-
-! this is the exit condition, to go beyond the last phase number
- iphase = iphase + 1
-
-!! DK DK do the rest in blocking for now, for simplicity
-
-!----
-!---- 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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
- enddo
- call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
- enddo
-
-! send to worker #1
- receiver = iproc_worker1_corners(imsg)
- call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
- receiver,itag,MPI_COMM_WORLD,ier)
- endif
-
- endif
-
- enddo
-
- endif !!!!!!!!! end of iphase 7
-
- end subroutine assemble_MPI_scalar
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_scalar_block.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_scalar_block.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_scalar_block.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,439 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!----
-!---- assemble the contributions between slices and chunks using MPI
-!----
-
- subroutine assemble_MPI_scalar_block(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_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NCHUNKS)
-
-! this version of the routine is based on blocking MPI calls
-
- 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_CM_IC
- integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
- real(kind=CUSTOM_REAL), dimension(npoin2D_max_all_CM_IC) :: 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_chunkcorn_scalar,buffer_recv_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
- enddo
- call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
- enddo
-
-! send to worker #1
- receiver = iproc_worker1_corners(imsg)
- call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
- receiver,itag,MPI_COMM_WORLD,ier)
- endif
-
- endif
-
- enddo
-
- end subroutine assemble_MPI_scalar_block
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_vector.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_vector.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,890 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!----
-!---- 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, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces_vector,buffer_received_faces_vector,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL_crust_mantle, &
- NGLOB1D_RADIAL_inner_core,NCHUNKS,iphase)
-
- 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,iphase
-
-! the two arrays to assemble
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE), intent(inout) :: accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE), intent(inout) :: accel_inner_core
-
- integer, intent(in) :: iproc_xi,iproc_eta,ichunk
- integer, intent(in) :: npoin2D_faces_crust_mantle(NUMFACES_SHARED)
- integer, intent(in) :: npoin2D_faces_inner_core(NUMFACES_SHARED)
-
- integer, dimension(NB_SQUARE_EDGES_ONEDIR), intent(in) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core
-
- integer, intent(in) :: NGLOB1D_RADIAL_crust_mantle,NGLOB1D_RADIAL_inner_core,NPROC_XI,NPROC_ETA
- integer, intent(in) :: NUMMSGS_FACES,NCORNERSCHUNKS
-
-! for addressing of the slices
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1), intent(in) :: addressing
-
-! 2-D addressing and buffers for summation between slices
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM), intent(in) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM), intent(in) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC), intent(in) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC), intent(in) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
-
-! indirect addressing for each corner of the chunks
- integer, dimension(NGLOB1D_RADIAL_crust_mantle,NUMCORNERS_SHARED), intent(in) :: iboolcorner_crust_mantle
- integer, dimension(NGLOB1D_RADIAL_inner_core,NUMCORNERS_SHARED), intent(in) :: iboolcorner_inner_core
- integer icount_corners
-
- integer, intent(in) :: npoin2D_max_all_CM_IC
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED), intent(in) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED), intent(in) :: iboolfaces_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED), intent(inout) :: &
- 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), intent(inout) :: &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector
-
-! ---- arrays to assemble between chunks
-
-! communication pattern for faces between chunks
- integer, dimension(NUMMSGS_FACES), intent(in) :: iprocfrom_faces,iprocto_faces
-
-! communication pattern for corners between chunks
- integer, dimension(NCORNERSCHUNKS), intent(in) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
-! MPI status of messages to be received
- integer, dimension(MPI_STATUS_SIZE) :: msg_status
-
- integer :: ipoin,ipoin2D,ipoin1D
- integer :: sender,receiver
- integer :: imsg
- integer :: icount_faces,npoin2D_chunks_all
-
- integer :: NGLOB1D_RADIAL_all
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_all,npoin2D_eta_all
-
-! do not remove the "save" statement because this routine is non blocking
-! therefore it needs to find the right value of ioffset when it re-enters
-! the routine later to perform the next communication step
- integer, save :: ioffset
-
- integer :: ier
-! do not remove the "save" statement because this routine is non blocking
- integer, save :: request_send,request_receive
- integer, dimension(NUMFACES_SHARED), save :: request_send_array,request_receive_array
- logical :: flag_result_test
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! check flag to see if we need to assemble (might be turned off when debugging)
- if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) then
- iphase = 9999 ! this means everything is finished
- return
- endif
-
-! 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
-!----
-
-!----
-!---- first assemble along xi using the 2-D topology
-!----
-
- if(iphase == 1) then
-
-! slices copy the right face into the buffer
- do ipoin = 1,npoin2D_xi_crust_mantle(2)
- buffer_send_faces_vector(1,ipoin,1) = accel_crust_mantle(1,iboolright_xi_crust_mantle(ipoin))
- buffer_send_faces_vector(2,ipoin,1) = accel_crust_mantle(2,iboolright_xi_crust_mantle(ipoin))
- buffer_send_faces_vector(3,ipoin,1) = accel_crust_mantle(3,iboolright_xi_crust_mantle(ipoin))
- enddo
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_xi_crust_mantle(2)
-
- do ipoin = 1,npoin2D_xi_inner_core(2)
- buffer_send_faces_vector(1,ioffset + ipoin,1) = accel_inner_core(1,iboolright_xi_inner_core(ipoin))
- buffer_send_faces_vector(2,ioffset + ipoin,1) = accel_inner_core(2,iboolright_xi_inner_core(ipoin))
- buffer_send_faces_vector(3,ioffset + ipoin,1) = accel_inner_core(3,iboolright_xi_inner_core(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_IRECV(buffer_received_faces_vector,NDIM*npoin2D_xi_all(1),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive,ier)
-
- call MPI_ISSEND(buffer_send_faces_vector,NDIM*npoin2D_xi_all(2),CUSTOM_MPI_TYPE,receiver, &
- itag2,MPI_COMM_WORLD,request_send,ier)
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 1
-
- if(iphase == 2) then
-
-! call MPI_WAIT(request_send,msg_status,ier)
-! call MPI_WAIT(request_receive,msg_status,ier)
- call MPI_TEST(request_send,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
-
-! 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(1)
- accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(1,ipoin,1)
- accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(2,ipoin,1)
- accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(3,ipoin,1)
- enddo
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_xi_crust_mantle(1)
-
- do ipoin = 1,npoin2D_xi_inner_core(1)
- accel_inner_core(1,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(1,iboolleft_xi_inner_core(ipoin)) + &
- buffer_received_faces_vector(1,ioffset + ipoin,1)
- 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,1)
- 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,1)
- 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(1)
- buffer_send_faces_vector(1,ipoin,1) = accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin))
- buffer_send_faces_vector(2,ipoin,1) = accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin))
- buffer_send_faces_vector(3,ipoin,1) = accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin))
- enddo
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_xi_crust_mantle(1)
-
- do ipoin = 1,npoin2D_xi_inner_core(1)
- buffer_send_faces_vector(1,ioffset + ipoin,1) = accel_inner_core(1,iboolleft_xi_inner_core(ipoin))
- buffer_send_faces_vector(2,ioffset + ipoin,1) = accel_inner_core(2,iboolleft_xi_inner_core(ipoin))
- buffer_send_faces_vector(3,ioffset + ipoin,1) = accel_inner_core(3,iboolleft_xi_inner_core(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_IRECV(buffer_received_faces_vector,NDIM*npoin2D_xi_all(2),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive,ier)
-
- call MPI_ISSEND(buffer_send_faces_vector,NDIM*npoin2D_xi_all(1),CUSTOM_MPI_TYPE,receiver, &
- itag2,MPI_COMM_WORLD,request_send,ier)
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 2
-
- if(iphase == 3) then
-
-! call MPI_WAIT(request_send,msg_status,ier)
-! call MPI_WAIT(request_receive,msg_status,ier)
- call MPI_TEST(request_send,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
-
-! 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(2)
- accel_crust_mantle(1,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin,1)
- accel_crust_mantle(2,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(2,ipoin,1)
- accel_crust_mantle(3,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(3,ipoin,1)
- enddo
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_xi_crust_mantle(2)
-
- do ipoin = 1,npoin2D_xi_inner_core(2)
- accel_inner_core(1,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin,1)
- accel_inner_core(2,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(2,ioffset + ipoin,1)
- accel_inner_core(3,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(3,ioffset + ipoin,1)
- enddo
-
- endif
-
-!----
-!---- then assemble along eta using the 2-D topology
-!----
-
-! slices copy the right face into the buffer
- do ipoin = 1,npoin2D_eta_crust_mantle(2)
- buffer_send_faces_vector(1,ipoin,1) = accel_crust_mantle(1,iboolright_eta_crust_mantle(ipoin))
- buffer_send_faces_vector(2,ipoin,1) = accel_crust_mantle(2,iboolright_eta_crust_mantle(ipoin))
- buffer_send_faces_vector(3,ipoin,1) = accel_crust_mantle(3,iboolright_eta_crust_mantle(ipoin))
- enddo
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_eta_crust_mantle(2)
-
- do ipoin = 1,npoin2D_eta_inner_core(2)
- buffer_send_faces_vector(1,ioffset + ipoin,1) = accel_inner_core(1,iboolright_eta_inner_core(ipoin))
- buffer_send_faces_vector(2,ioffset + ipoin,1) = accel_inner_core(2,iboolright_eta_inner_core(ipoin))
- buffer_send_faces_vector(3,ioffset + ipoin,1) = accel_inner_core(3,iboolright_eta_inner_core(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_IRECV(buffer_received_faces_vector,NDIM*npoin2D_eta_all(1),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive,ier)
-
- call MPI_ISSEND(buffer_send_faces_vector,NDIM*npoin2D_eta_all(2),CUSTOM_MPI_TYPE,receiver, &
- itag2,MPI_COMM_WORLD,request_send,ier)
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 3
-
- if(iphase == 4) then
-
-! call MPI_WAIT(request_send,msg_status,ier)
-! call MPI_WAIT(request_receive,msg_status,ier)
- call MPI_TEST(request_send,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
-
-! 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(1)
- accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(1,ipoin,1)
- accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(2,ipoin,1)
- accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(3,ipoin,1)
- enddo
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_eta_crust_mantle(1)
-
- do ipoin = 1,npoin2D_eta_inner_core(1)
- accel_inner_core(1,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(1,iboolleft_eta_inner_core(ipoin)) + &
- buffer_received_faces_vector(1,ioffset + ipoin,1)
- 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,1)
- 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,1)
- 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(1)
- buffer_send_faces_vector(1,ipoin,1) = accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin))
- buffer_send_faces_vector(2,ipoin,1) = accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin))
- buffer_send_faces_vector(3,ipoin,1) = accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin))
- enddo
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_eta_crust_mantle(1)
-
- do ipoin = 1,npoin2D_eta_inner_core(1)
- buffer_send_faces_vector(1,ioffset + ipoin,1) = accel_inner_core(1,iboolleft_eta_inner_core(ipoin))
- buffer_send_faces_vector(2,ioffset + ipoin,1) = accel_inner_core(2,iboolleft_eta_inner_core(ipoin))
- buffer_send_faces_vector(3,ioffset + ipoin,1) = accel_inner_core(3,iboolleft_eta_inner_core(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_IRECV(buffer_received_faces_vector,NDIM*npoin2D_eta_all(2),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive,ier)
-
- call MPI_ISSEND(buffer_send_faces_vector,NDIM*npoin2D_eta_all(1),CUSTOM_MPI_TYPE,receiver, &
- itag2,MPI_COMM_WORLD,request_send,ier)
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 4
-
- if(iphase == 5) then
-
-! call MPI_WAIT(request_send,msg_status,ier)
-! call MPI_WAIT(request_receive,msg_status,ier)
- call MPI_TEST(request_send,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
-
-! 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(2)
- accel_crust_mantle(1,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin,1)
- accel_crust_mantle(2,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(2,ipoin,1)
- accel_crust_mantle(3,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(3,ipoin,1)
- enddo
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_eta_crust_mantle(2)
-
- do ipoin = 1,npoin2D_eta_inner_core(2)
- accel_inner_core(1,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin,1)
- accel_inner_core(2,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(2,ioffset + ipoin,1)
- accel_inner_core(3,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(3,ioffset + ipoin,1)
- enddo
-
- 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) then
- iphase = 9999 ! this means everything is finished
- return
- endif
-
-! ***************************************************************
-! transmit messages in forward direction (iprocfrom -> iprocto)
-! ***************************************************************
-
-!---- 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==iprocto_faces(imsg)) 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)
-
- call MPI_IRECV(buffer_received_faces_vector(:,:,icount_faces),NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive_array(icount_faces),ier)
-
-! do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
-! accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
-! accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ipoin2D,icount_faces)
-! 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,icount_faces)
-! 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,icount_faces)
-! enddo
-
-! 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_inner_core(icount_faces)
-! accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
-! accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) + &
-! buffer_received_faces_vector(1,ioffset + ipoin2D,icount_faces)
-! 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,icount_faces)
-! 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,icount_faces)
-! 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)) 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)
-
- do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
- buffer_send_faces_vector(1,ipoin2D,icount_faces) = accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- buffer_send_faces_vector(2,ipoin2D,icount_faces) = accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- buffer_send_faces_vector(3,ipoin2D,icount_faces) = accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- enddo
-
-! 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_inner_core(icount_faces)
- buffer_send_faces_vector(1,ioffset + ipoin2D,icount_faces) = accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces))
- buffer_send_faces_vector(2,ioffset + ipoin2D,icount_faces) = accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces))
- buffer_send_faces_vector(3,ioffset + ipoin2D,icount_faces) = accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces))
- enddo
-
- call MPI_ISSEND(buffer_send_faces_vector(:,:,icount_faces),NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,receiver,itag, &
- MPI_COMM_WORLD,request_send_array(icount_faces),ier)
- endif
- enddo
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 5
-
- if(iphase == 6) then
-
- 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)) then
- call MPI_TEST(request_receive_array(icount_faces),flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
- endif
- enddo
-
- 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)) then
- call MPI_TEST(request_send_array(icount_faces),flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- endif
- enddo
-
- 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)) then
-
- do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
- accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
- accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ipoin2D,icount_faces)
- 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,icount_faces)
- 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,icount_faces)
- enddo
-
-! 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_inner_core(icount_faces)
- accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
- accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) + &
- buffer_received_faces_vector(1,ioffset + ipoin2D,icount_faces)
- 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,icount_faces)
- 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,icount_faces)
- enddo
-
- 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)) 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)
-
- call MPI_IRECV(buffer_received_faces_vector(:,:,icount_faces),NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,request_receive_array(icount_faces),ier)
-
-! do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
-! accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ipoin2D,icount_faces)
-! accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(2,ipoin2D,icount_faces)
-! accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(3,ipoin2D,icount_faces)
-! enddo
-
-! 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_inner_core(icount_faces)
-! accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
-! buffer_received_faces_vector(1,ioffset + ipoin2D,icount_faces)
-! accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
-! buffer_received_faces_vector(2,ioffset + ipoin2D,icount_faces)
-! accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
-! buffer_received_faces_vector(3,ioffset + ipoin2D,icount_faces)
-! 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)) 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)
-
- do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
- buffer_send_faces_vector(1,ipoin2D,icount_faces) = accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- buffer_send_faces_vector(2,ipoin2D,icount_faces) = accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- buffer_send_faces_vector(3,ipoin2D,icount_faces) = accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- enddo
-
-! 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_inner_core(icount_faces)
- buffer_send_faces_vector(1,ioffset + ipoin2D,icount_faces) = accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces))
- buffer_send_faces_vector(2,ioffset + ipoin2D,icount_faces) = accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces))
- buffer_send_faces_vector(3,ioffset + ipoin2D,icount_faces) = accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces))
- enddo
-
- call MPI_ISSEND(buffer_send_faces_vector(:,:,icount_faces),NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,receiver,itag, &
- MPI_COMM_WORLD,request_send_array(icount_faces),ier)
- endif
- enddo
-
- iphase = iphase + 1
- return ! exit because we have started some communications therefore we need some time
-
- endif !!!!!!!!! end of iphase 6
-
- if(iphase == 7) then
-
- 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)) then
- call MPI_TEST(request_send_array(icount_faces),flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not received yet
- endif
- enddo
-
- 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)) then
- call MPI_TEST(request_receive_array(icount_faces),flag_result_test,msg_status,ier)
- if(.not. flag_result_test) return ! exit if message not sent yet
- endif
- enddo
-
- 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)) then
- do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
- accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ipoin2D,icount_faces)
- accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(2,ipoin2D,icount_faces)
- accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(3,ipoin2D,icount_faces)
- enddo
-
-! 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_inner_core(icount_faces)
- accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
- buffer_received_faces_vector(1,ioffset + ipoin2D,icount_faces)
- accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
- buffer_received_faces_vector(2,ioffset + ipoin2D,icount_faces)
- accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
- buffer_received_faces_vector(3,ioffset + ipoin2D,icount_faces)
- enddo
- endif
- enddo
-
-! this is the exit condition, to go beyond the last phase number
- iphase = iphase + 1
-
-!! DK DK do the rest in blocking for now, for simplicity
-
-!----
-!---- 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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- buffer_send_chunkcorn_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(3,ioffset + ipoin1D) = accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners))
- enddo
-
- call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_vector(1,ipoin1D)
- accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(2,ipoin1D)
- accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(3,ipoin1D)
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(1,ioffset + ipoin1D)
- accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(2,ioffset + ipoin1D)
- accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_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_chunkcorn_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- buffer_send_chunkcorn_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
-
- endif
-
- endif
-
- enddo
-
- endif !!!!!!!!! end of iphase 7
-
- end subroutine assemble_MPI_vector
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_vector_block.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_vector_block.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_vector_block.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,707 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!----
-!---- 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_block(myrank, &
- accel_crust_mantle,NGLOB_CRUST_MANTLE, &
- accel_inner_core,NGLOB_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, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA, &
- NGLOB1D_RADIAL_crust_mantle, &
- NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM, &
- NGLOB1D_RADIAL_inner_core, &
- NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC, &
- NGLOB2DMAX_XY,NCHUNKS)
-
-! this version of the routine is based on blocking MPI calls
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
- integer myrank,NGLOB_CRUST_MANTLE,NGLOB_INNER_CORE,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, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
- integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
- integer npoin2D_faces_inner_core(NUMFACES_SHARED)
-
- integer NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM,NGLOB1D_RADIAL_crust_mantle
- integer NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC,NGLOB1D_RADIAL_inner_core
- integer NPROC_XI,NPROC_ETA,NGLOB2DMAX_XY
- 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_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, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces_crust_mantle,iboolfaces_inner_core
-! size of buffers is multiplied by 2 because we handle two regions in the same MPI call
- real(kind=CUSTOM_REAL), dimension(NDIM,2*NGLOB2DMAX_XY) :: 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_chunkcorn_vector,buffer_recv_chunkcorn_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
- integer icount_faces,npoin2D_chunks_all
-
- integer :: NGLOB1D_RADIAL_all,ioffset
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_all,npoin2D_eta_all
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! 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
-!----
-
-!----
-!---- 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
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_xi_crust_mantle(2)
-
- do ipoin = 1,npoin2D_xi_crust_mantle(2)
- buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolright_xi_crust_mantle(ipoin))
- 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))
- enddo
-
- do ipoin = 1,npoin2D_xi_inner_core(2)
- buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolright_xi_inner_core(ipoin))
- 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))
- 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*npoin2D_xi_all(2),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_vector,NDIM*npoin2D_xi_all(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_crust_mantle(1)
- accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(1,ipoin)
- 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)
- enddo
-
- ioffset = npoin2D_xi_crust_mantle(1)
- do ipoin = 1,npoin2D_xi_inner_core(1)
- accel_inner_core(1,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(1,iboolleft_xi_inner_core(ipoin)) + &
- buffer_received_faces_vector(1,ioffset + ipoin)
- 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)
- 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
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_xi_crust_mantle(1)
-
- do ipoin = 1,npoin2D_xi_crust_mantle(1)
- buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin))
- 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))
- enddo
-
- do ipoin = 1,npoin2D_xi_inner_core(1)
- buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolleft_xi_inner_core(ipoin))
- 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))
- 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*npoin2D_xi_all(1),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_vector,NDIM*npoin2D_xi_all(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_crust_mantle(2)
- accel_crust_mantle(1,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin)
- 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)
- enddo
-
- ioffset = npoin2D_xi_crust_mantle(2)
- do ipoin = 1,npoin2D_xi_inner_core(2)
- accel_inner_core(1,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin)
- 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)
- 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(2)
-
-! slices copy the right face into the buffer
- do ipoin = 1,npoin2D_eta_crust_mantle(2)
- buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolright_eta_crust_mantle(ipoin))
- 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))
- enddo
-
- do ipoin = 1,npoin2D_eta_inner_core(2)
- buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolright_eta_inner_core(ipoin))
- 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))
- 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*npoin2D_eta_all(2),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_vector,NDIM*npoin2D_eta_all(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_crust_mantle(1)
- accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(1,ipoin)
- 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)
- enddo
-
- ioffset = npoin2D_eta_crust_mantle(1)
- do ipoin = 1,npoin2D_eta_inner_core(1)
- accel_inner_core(1,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(1,iboolleft_eta_inner_core(ipoin)) + &
- buffer_received_faces_vector(1,ioffset + ipoin)
- 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)
- 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
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_eta_crust_mantle(1)
-
- do ipoin = 1,npoin2D_eta_crust_mantle(1)
- buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin))
- 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))
- enddo
-
- do ipoin = 1,npoin2D_eta_inner_core(1)
- buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolleft_eta_inner_core(ipoin))
- 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))
- 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*npoin2D_eta_all(1),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_vector,NDIM*npoin2D_eta_all(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_crust_mantle(2)
- accel_crust_mantle(1,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin)
- 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)
- enddo
-
- ioffset = npoin2D_eta_crust_mantle(2)
- do ipoin = 1,npoin2D_eta_inner_core(2)
- accel_inner_core(1,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin)
- 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)
- 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*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(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
- accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ipoin2D)
- 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)
- enddo
-
- do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
- accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
- accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ioffset + ipoin2D)
- 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)
- 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(1,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- 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))
- enddo
-
- do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
- buffer_send_faces_vector(1,ioffset + ipoin2D) = accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces))
- 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))
- enddo
-
- call MPI_SEND(buffer_send_faces_vector,NDIM*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*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(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ipoin2D)
- 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)
- enddo
-
- do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
- accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ioffset + ipoin2D)
- 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)
- 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(1,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- 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))
- enddo
-
- do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
- buffer_send_faces_vector(1,ioffset + ipoin2D) = accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces))
- 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))
- enddo
-
- call MPI_SEND(buffer_send_faces_vector,NDIM*npoin2D_chunks_all,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
-
-! 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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- buffer_send_chunkcorn_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(3,ioffset + ipoin1D) = accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners))
- enddo
-
- call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_vector(1,ipoin1D)
- accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(2,ipoin1D)
- accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(3,ipoin1D)
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(1,ioffset + ipoin1D)
- accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(2,ioffset + ipoin1D)
- accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_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_chunkcorn_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- buffer_send_chunkcorn_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorn_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
-
- endif
-
- endif
-
- enddo
-
- end subroutine assemble_MPI_vector_block
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/auto_ner.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/auto_ner.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/auto_ner.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,586 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-!
-! 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
- stop '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, CRUSTAL, &
- HONOR_1D_SPHERICAL_MOHO, REFERENCE_1D_MODEL)
-
- 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,CRUSTAL,HONOR_1D_SPHERICAL_MOHO
- integer REFERENCE_1D_MODEL
-
- ! local parameters
- 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
- double precision ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
- double precision RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS
-
- ! 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
-
- ! gets model specific radii used to determine number of elements in radial direction
- call get_model_parameters_radii(REFERENCE_1D_MODEL,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771, &
- RTOPDDOUBLEPRIME,RCMB,RICB, &
- RMOHO_FICTITIOUS_IN_MESHER, &
- R80_FICTITIOUS_IN_MESHER, &
- RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
- HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL)
-
- radius(1) = R_EARTH ! Surface
- radius(2) = RMOHO_FICTITIOUS_IN_MESHER ! Moho - 1st Mesh Doubling Interface
- radius(3) = R80 ! 80
- radius(4) = R220 ! 220
- radius(5) = R400 ! 400
- radius(6) = R600 ! 600
- radius(7) = R670 ! 670
- radius(8) = R771 ! 771
- radius(9) = 4712000.0d0 ! 1650 - 2nd Mesh Doubling: Geochemical Layering; Kellogg et al. 1999, Science
- radius(10) = RTOPDDOUBLEPRIME ! D''
- radius(11) = RCMB ! CMB
- radius(12) = 2511000.0d0 ! 3860 - 3rd Mesh Doubling Interface
- radius(13) = 1371000.0d0 ! 5000 - 4th Mesh Doubling Interface
- radius(14) = 982000.0d0 ! Top Central Cube
-
- ! radii in km
- radius(:) = radius(:) / 1000.0d0
-
- 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 ), : )
- 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/broadcast_compute_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/broadcast_compute_parameters.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/broadcast_compute_parameters.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,319 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine broadcast_compute_parameters(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- RMOHO_FICTITIOUS_IN_MESHER, &
- MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
- LOCAL_PATH,MODEL, &
- 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, &
- ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
- HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
- ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
- include "constants.h"
- include "precision.h"
-
- integer myrank
-
- ! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- RMOHO_FICTITIOUS_IN_MESHER
-
- logical MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT,&
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE
-
- character(len=150) LOCAL_PATH,MODEL
-
- ! parameters to be computed based upon parameters above read from file
- integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
-
- 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, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ratio_sampling_array,ner
- 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
-
- integer ratio_divide_central_cube
-
- ! for the cut doublingbrick improvement
- 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
-
- ! mesh model parameters
- integer REFERENCE_1D_MODEL,THREE_D_MODEL
-
- logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
- HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
- ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE
-
- ! local parameters
- double precision, dimension(31) :: bcast_double_precision
- integer, dimension(39) :: bcast_integer
- logical, dimension(35) :: bcast_logical
- integer ier
-
- ! master process prepares broadcasting arrays
- if (myrank==0) then
- ! count the total number of sources in the CMTSOLUTION file
- call count_number_of_sources(NSOURCES)
-
- ! funny way to pass parameters in arrays from master to all other processes
- ! rather than single values one by one to reduce MPI communication calls:
- ! sets up broadcasting array
- 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, &
- 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,NSOURCES,NOISE_TOMOGRAPHY/)
-
- bcast_logical = (/TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,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, &
- HONOR_1D_SPHERICAL_MOHO,MOVIE_COARSE, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE/)
-
- 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,&
- RMOHO_FICTITIOUS_IN_MESHER /)
- endif
-
- ! broadcasts the information read on the master to the nodes
- call MPI_BCAST(bcast_integer,39,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(bcast_double_precision,31,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(bcast_logical,35,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
-
- ! broadcasts non-single value parameters
- call MPI_BCAST(LOCAL_PATH,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
- 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,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)
-
- ! non-master processes set their parameters
- if (myrank /=0) then
-
- ! please, be careful with ordering and counting here
- ! integers
- 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)
- NPROC_XI = bcast_integer(16)
- NPROC_ETA = bcast_integer(17)
- NTSTEP_BETWEEN_OUTPUT_SEISMOS = bcast_integer(18)
- NTSTEP_BETWEEN_READ_ADJSRC = bcast_integer(19)
- NSTEP = bcast_integer(20)
- NSOURCES = bcast_integer(21)
- NTSTEP_BETWEEN_FRAMES = bcast_integer(22)
- NTSTEP_BETWEEN_OUTPUT_INFO = bcast_integer(23)
- NUMBER_OF_RUNS = bcast_integer(24)
- NUMBER_OF_THIS_RUN = bcast_integer(25)
- NCHUNKS = bcast_integer(26)
- SIMULATION_TYPE = bcast_integer(27)
- REFERENCE_1D_MODEL = bcast_integer(28)
- THREE_D_MODEL = bcast_integer(29)
- NPROC = bcast_integer(30)
- NPROCTOT = bcast_integer(31)
- NEX_PER_PROC_XI = bcast_integer(32)
- NEX_PER_PROC_ETA = bcast_integer(33)
- ratio_divide_central_cube = bcast_integer(34)
- MOVIE_VOLUME_TYPE = bcast_integer(35)
- MOVIE_START = bcast_integer(36)
- MOVIE_STOP = bcast_integer(37)
- NSOURCES = bcast_integer(38)
- NOISE_TOMOGRAPHY = bcast_integer(39)
-
- ! logicals
- 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)
- HETEROGEN_3D_MANTLE = bcast_logical(10)
- TOPOGRAPHY = bcast_logical(11)
- OCEANS = bcast_logical(12)
- MOVIE_SURFACE = bcast_logical(13)
- MOVIE_VOLUME = 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)
- CUT_SUPERBRICK_XI = bcast_logical(25)
- CUT_SUPERBRICK_ETA = bcast_logical(26)
- SAVE_ALL_SEISMOS_IN_ONE_FILE = bcast_logical(27)
- HONOR_1D_SPHERICAL_MOHO = bcast_logical(28)
- MOVIE_COARSE= bcast_logical(29)
- OUTPUT_SEISMOS_ASCII_TEXT= bcast_logical(30)
- OUTPUT_SEISMOS_SAC_ALPHANUM= bcast_logical(31)
- OUTPUT_SEISMOS_SAC_BINARY= bcast_logical(32)
- ROTATE_SEISMOGRAMS_RT= bcast_logical(33)
- WRITE_SEISMOGRAMS_BY_MASTER= bcast_logical(34)
- USE_BINARY_FOR_LARGE_FILE= bcast_logical(35)
-
- ! double precisions
- 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)
- RMOHO_FICTITIOUS_IN_MESHER = bcast_double_precision(31)
-
- endif
-
- end subroutine broadcast_compute_parameters
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/calc_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/calc_jacobian.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/calc_jacobian.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,501 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-!
-!> Hejun
-! This subroutine recomputes the 3D jacobian for one element
-! based upon 125 GLL points
-! Hejun Zhu OCT16,2009
-
-! input: myrank,
-! xstore,ystore,zstore ----- input GLL point coordinate
-! xigll,yigll,zigll ----- gll points position
-! ispec,nspec ----- element number
-! ACTUALLY_STORE_ARRAYS ------ save array or not
-
-! output: xixstore,xiystore,xizstore,
-! etaxstore,etaystore,etazstore,
-! gammaxstore,gammaystore,gammazstore ------ parameters used to calculate jacobian
-
-
- subroutine recalc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
- ispec,nspec,ACTUALLY_STORE_ARRAYS,&
- xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore)
-
- implicit none
-
- include "constants.h"
-
- ! input parameter
- integer::myrank,ispec,nspec
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision, dimension(NGLLX):: xigll
- double precision, dimension(NGLLY):: yigll
- double precision, dimension(NGLLZ):: zigll
- logical::ACTUALLY_STORE_ARRAYS
-
-
- ! output results
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xixstore,xiystore,xizstore,&
- etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore
-
-
- ! local parameters for this subroutine
- integer:: i,j,k,i1,j1,k1
- double precision:: xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
- double precision:: xi,eta,gamma
- double precision,dimension(NGLLX):: hxir,hpxir
- double precision,dimension(NGLLY):: hetar,hpetar
- double precision,dimension(NGLLZ):: hgammar,hpgammar
- double precision:: hlagrange,hlagrange_xi,hlagrange_eta,hlagrange_gamma
- double precision:: jacobian
- double precision:: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- double precision:: r,theta,phi
-
-
- ! test parameters which can be deleted
- double precision:: xmesh,ymesh,zmesh
- double precision:: sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
-
- ! first go over all 125 GLL points
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- xxi = 0.0
- xeta = 0.0
- xgamma = 0.0
- yxi = 0.0
- yeta = 0.0
- ygamma = 0.0
- zxi = 0.0
- zeta = 0.0
- zgamma = 0.0
-
- xi = xigll(i)
- eta = yigll(j)
- gamma = zigll(k)
-
- ! calculate lagrange polynomial and its derivative
- call lagrange_any(xi,NGLLX,xigll,hxir,hpxir)
- call lagrange_any(eta,NGLLY,yigll,hetar,hpetar)
- call lagrange_any(gamma,NGLLZ,zigll,hgammar,hpgammar)
-
- ! test parameters
- sumshape = 0.0
- sumdershapexi = 0.0
- sumdershapeeta = 0.0
- sumdershapegamma = 0.0
- xmesh = 0.0
- ymesh = 0.0
- zmesh = 0.0
-
-
- do k1 = 1,NGLLZ
- do j1 = 1,NGLLY
- do i1 = 1,NGLLX
- hlagrange = hxir(i1)*hetar(j1)*hgammar(k1)
- hlagrange_xi = hpxir(i1)*hetar(j1)*hgammar(k1)
- hlagrange_eta = hxir(i1)*hpetar(j1)*hgammar(k1)
- hlagrange_gamma = hxir(i1)*hetar(j1)*hpgammar(k1)
-
-
- xxi = xxi + xstore(i1,j1,k1,ispec)*hlagrange_xi
- xeta = xeta + xstore(i1,j1,k1,ispec)*hlagrange_eta
- xgamma = xgamma + xstore(i1,j1,k1,ispec)*hlagrange_gamma
-
- yxi = yxi + ystore(i1,j1,k1,ispec)*hlagrange_xi
- yeta = yeta + ystore(i1,j1,k1,ispec)*hlagrange_eta
- ygamma = ygamma + ystore(i1,j1,k1,ispec)*hlagrange_gamma
-
- zxi = zxi + zstore(i1,j1,k1,ispec)*hlagrange_xi
- zeta = zeta + zstore(i1,j1,k1,ispec)*hlagrange_eta
- zgamma = zgamma + zstore(i1,j1,k1,ispec)*hlagrange_gamma
-
- ! test the lagrange polynomial and its derivate
- xmesh = xmesh + xstore(i1,j1,k1,ispec)*hlagrange
- ymesh = ymesh + ystore(i1,j1,k1,ispec)*hlagrange
- zmesh = zmesh + zstore(i1,j1,k1,ispec)*hlagrange
- sumshape = sumshape + hlagrange
- sumdershapexi = sumdershapexi + hlagrange_xi
- sumdershapeeta = sumdershapeeta + hlagrange_eta
- sumdershapegamma = sumdershapegamma + hlagrange_gamma
-
- end do
- end do
- end do
-
- ! Check the lagrange polynomial and its derivative
- if (abs(xmesh - xstore(i,j,k,ispec)) > TINYVAL &
- .or. abs(ymesh - ystore(i,j,k,ispec)) > TINYVAL &
- .or. abs(zmesh - zstore(i,j,k,ispec)) > TINYVAL ) then
- call exit_MPI(myrank,'new mesh are wrong in recalc_jacobian_gall3D.f90')
- end if
- if(abs(sumshape-one) > TINYVAL) then
- call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll3D.f90')
- end if
- if(abs(sumdershapexi) > TINYVAL) then
- call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll3D.f90')
- end if
- if(abs(sumdershapeeta) > TINYVAL) then
- call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll3D.f90')
- end if
- if(abs(sumdershapegamma) > TINYVAL) then
- call exit_MPI(myrank,'error derivative gamma in recalc_jacobian_gll3D.f90')
- end if
-
-
- jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
- xeta*(yxi*zgamma-ygamma*zxi) + &
- xgamma*(yxi*zeta-yeta*zxi)
-
- ! Check the jacobian
- if(jacobian <= ZERO) then
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r,theta,phi)
- print*,'r/lat/lon:',r*R_EARTH_KM,90.0-theta*180./PI,phi*180./PI
- call exit_MPI(myrank,'3D Jacobian undefined in recalc_jacobian_gll3D.f90')
- end if
-
- ! 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
-
-
- ! resave the derivatives and the jacobian
- ! distinguish between single and double precision for reals
- if (ACTUALLY_STORE_ARRAYS) then
- 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)
- 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
- endif
- end if
- enddo
- enddo
- enddo
-
- end subroutine recalc_jacobian_gll3D
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- ! Hejun Zhu used to recalculate 2D jacobian according to gll points rather
- ! than control nodes
- ! Hejun Zhu JAN08, 2010
-
- ! input parameters: myrank,ispecb,
- ! xelm2D,yelm2D,zelm2D,
- ! xigll,yigll,NSPEC2DMAX_AB,NGLLA,NGLLB
-
- ! output results: jacobian2D,normal
- subroutine recalc_jacobian_gll2D(myrank,ispecb, &
- xelm2D,yelm2D,zelm2D,xigll,yigll,&
- jacobian2D,normal,NGLLA,NGLLB,NSPEC2DMAX_AB)
-
- implicit none
- include "constants.h"
- ! input parameters
- integer::myrank,ispecb,NSPEC2DMAX_AB,NGLLA,NGLLB
- double precision,dimension(NGLLA,NGLLB)::xelm2D,yelm2D,zelm2D
- double precision,dimension(NGLLA)::xigll
- double precision,dimension(NGLLB)::yigll
-
- ! output results
- real(kind=CUSTOM_REAL),dimension(NGLLA,NGLLB,NSPEC2DMAX_AB)::jacobian2D
- real(kind=CUSTOM_REAL),dimension(3,NGLLA,NGLLB,NSPEC2DMAX_AB)::normal
-
-
- ! local parameters in this subroutine
- integer::i,j,i1,j1
- double precision::xxi,xeta,yxi,yeta,zxi,zeta,&
- xi,eta,xmesh,ymesh,zmesh,hlagrange,hlagrange_xi,hlagrange_eta,&
- sumshape,sumdershapexi,sumdershapeeta,unx,uny,unz,jacobian
- double precision,dimension(NGLLA)::hxir,hpxir
- double precision,dimension(NGLLB)::hetar,hpetar
-
- do j = 1,NGLLB
- do i = 1,NGLLA
- xxi = 0.0
- xeta = 0.0
- yxi = 0.0
- yeta = 0.0
- zxi = 0.0
- zeta = 0.0
-
- xi=xigll(i)
- eta = yigll(j)
-
- call lagrange_any(xi,NGLLA,xigll,hxir,hpxir)
- call lagrange_any(eta,NGLLB,yigll,hetar,hpetar)
-
-
- xmesh = 0.0
- ymesh = 0.0
- zmesh = 0.0
- sumshape = 0.0
- sumdershapexi = 0.0
- sumdershapeeta = 0.0
- do j1 = 1,NGLLB
- do i1 = 1,NGLLA
- hlagrange = hxir(i1)*hetar(j1)
- hlagrange_xi = hpxir(i1)*hetar(j1)
- hlagrange_eta = hxir(i1)*hpetar(j1)
-
- xxi = xxi + xelm2D(i1,j1)*hlagrange_xi
- xeta = xeta + xelm2D(i1,j1)*hlagrange_eta
-
- yxi = yxi + yelm2D(i1,j1)*hlagrange_xi
- yeta = yeta + yelm2D(i1,j1)*hlagrange_eta
-
- zxi = zxi + zelm2D(i1,j1)*hlagrange_xi
- zeta = zeta + zelm2D(i1,j1)*hlagrange_eta
-
- xmesh = xmesh + xelm2D(i1,j1)*hlagrange
- ymesh = ymesh + yelm2D(i1,j1)*hlagrange
- zmesh = zmesh + zelm2D(i1,j1)*hlagrange
- sumshape = sumshape + hlagrange
- sumdershapexi = sumdershapexi + hlagrange_xi
- sumdershapeeta = sumdershapeeta + hlagrange_eta
- end do
- end do
-
-
- ! Check the lagrange polynomial
- if ( abs(xmesh - xelm2D(i,j)) > TINYVAL &
- .or. abs(ymesh - yelm2D(i,j)) > TINYVAL &
- .or. abs(zmesh - zelm2D(i,j)) > TINYVAL ) then
- call exit_MPI(myrank,'new boundary mesh is wrong in recalc_jacobian_gll2D')
- end if
-
- if (abs(sumshape-one) > TINYVAL) then
- call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll2D')
- end if
- if (abs(sumdershapexi) > TINYVAL) then
- call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll2D')
- end if
- if (abs(sumdershapeeta) > TINYVAL) then
- call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll2D')
- end if
-
- unx = yxi*zeta - yeta*zxi
- uny = zxi*xeta - zeta*xxi
- unz = xxi*yeta - xeta*yxi
- jacobian = dsqrt(unx**2+uny**2+unz**2)
- if (abs(jacobian) < TINYVAL ) call exit_MPI(myrank,'2D Jacobian undefined in recalc_jacobian_gll2D')
-
- 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
- end do
- end do
-
- end subroutine recalc_jacobian_gll2D
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-! deprecated...
-!
-! subroutine calc_jacobian(myrank,xixstore,xiystore,xizstore, &
-! etaxstore,etaystore,etazstore, &
-! gammaxstore,gammaystore,gammazstore, &
-! xstore,ystore,zstore, &
-! xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec,ACTUALLY_STORE_ARRAYS)
-!
-! implicit none
-!
-! include "constants.h"
-!
-! integer ispec,nspec,myrank
-!
-! logical ACTUALLY_STORE_ARRAYS
-!
-! 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)
-!
-! real(kind=CUSTOM_REAL) xixstore(NGLLX,NGLLY,NGLLZ,nspec), &
-! xiystore(NGLLX,NGLLY,NGLLZ,nspec), &
-! xizstore(NGLLX,NGLLY,NGLLZ,nspec), &
-! etaxstore(NGLLX,NGLLY,NGLLZ,nspec), &
-! etaystore(NGLLX,NGLLY,NGLLZ,nspec), &
-! etazstore(NGLLX,NGLLY,NGLLZ,nspec), &
-! gammaxstore(NGLLX,NGLLY,NGLLZ,nspec), &
-! gammaystore(NGLLX,NGLLY,NGLLZ,nspec), &
-! gammazstore(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)
-!
-! 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) then
-! print*,'jacobian error:',myrank
-! print*,' point ijk:',i,j,k,ispec
-! print*,' xyz:',xmesh,ymesh,zmesh
-! call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,xxi,xeta,xgamma)
-! print*,' r/lat/lon:',xxi*R_EARTH_KM,90.0-xeta*180./PI,xgamma*180./PI
-! print*,' nodes:'
-! do ia=1,NGNOD
-! print*,xelm(ia),yelm(ia),zelm(ia)
-! enddo
-! print*
-! print*,'maybe check with CAP smoothing'
-! call exit_MPI(myrank,'3D Jacobian undefined')
-! endif
-!
-!! 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(ACTUALLY_STORE_ARRAYS) then
-! 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)
-! 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
-! endif
-! 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/calendar.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/calendar.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/calendar.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,729 +0,0 @@
-
- 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
-
-
-!----------------------------------------------------------------------------------------------
-! open-source subroutines below taken from ftp://ftp.met.fsu.edu/pub/ahlquist/calendar_software
-!----------------------------------------------------------------------------------------------
-
- integer function idaywk(jdayno)
-
-! IDAYWK = compute the DAY of the WeeK given the Julian Day number,
-! version 1.0.
-
- implicit none
-
-! Input variable
- integer, intent(in) :: jdayno
-! jdayno = Julian Day number starting at noon of the day in question.
-
-! Output of the function:
-! idaywk = day of the week, where 0=Sunday, 1=Monday, ..., 6=Saturday.
-
-!----------
-! Compute the day of the week given the Julian Day number.
-! You can find the Julian Day number given (day,month,year)
-! using subroutine calndr below.
-! Example: For the first day of the Gregorian calendar,
-! Friday 15 October 1582, compute the Julian day number (option 3 of
-! subroutine calndr) and compute the day of the week.
-! call calndr (3, 15, 10, 1582, jdayno)
-! write(*,*) jdayno, idaywk(jdayno)
-! The numbers printed should be 2299161 and 5, where 5 refers to Friday.
-!
-! Copyright (C) 1999 Jon Ahlquist.
-! Issued under the second GNU General Public License.
-! See www.gnu.org for details.
-! 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.
-! If you find any errors, please notify:
-! Jon Ahlquist <ahlquist at met.fsu.edu>
-! Dept of Meteorology
-! Florida State University
-! Tallahassee, FL 32306-4520
-! 15 March 1999.
-!
-!-----
-
-! converted to Fortran90 by Dimitri Komatitsch,
-! University of Pau, France, January 2008.
-
-! jdSun is the Julian Day number starting at noon on any Sunday.
-! I arbitrarily chose the first Sunday after Julian Day 1,
-! which is Julian Day 6.
- integer, parameter :: jdSun = 6
-
- idaywk = mod(jdayno-jdSun,7)
-
-! If jdayno-jdSun < 0, then we are taking the modulus of a negative
-! number. Fortran's built-in mod function returns a negative value
-! when the argument is negative. In that case, we adjust the result
-! to a positive value.
- if (idaywk < 0) idaywk = idaywk + 7
-
- end function idaywk
-
-!
-!----
-!
-
- subroutine calndr(iday,month,iyear,idayct)
-
-! CALNDR = CALeNDaR conversions, version 1.0
-
- implicit none
-
-! specify the desired calendar conversion option.
-! in order to return the julian day number, compatible with function idaywk from above,
-! we choose option 3
-! (tested with dates: Feb, 23 2010 -> idaywk = Tue
-! Dec, 24 2009 -> idaywk = Thu
-! Oct, 15 1582 -> idaywk = Fri ...which all look o.k. )
- integer, parameter :: ioptn = 3
-
-! Input/Output variables
- integer, intent(inout) :: iday,month,iyear,idayct
-
-!----------
-!
-! Subroutine calndr() performs calendar calculations using either
-! the standard Gregorian calendar or the old Julian calendar.
-! This subroutine extends the definitions of these calendar systems
-! to any arbitrary year. The algorithms in this subroutine
-! will work with any date in the past or future,
-! but overflows will occur if the numbers are sufficiently large.
-! For a computer using a 32-bit integer, this routine can handle
-! any date between roughly 5.8 million BC and 5.8 million AD
-! without experiencing overflow during calculations.
-!
-! No external functions or subroutines are called.
-!
-!----------
-!
-! INPUT/OUTPUT ARGUMENTS FOR SUBROUTINE CALNDR()
-!
-! "ioptn" is the desired calendar conversion option explained below.
-! Positive option values use the standard modern Gregorian calendar.
-! Negative option values use the old Julian calendar which was the
-! standard in Europe from its institution by Julius Caesar in 45 BC
-! until at least 4 October 1582. The Gregorian and Julian calendars
-! are explained further below.
-!
-! (iday,month,iyear) is a calendar date where "iday" is the day of
-! the month, "month" is 1 for January, 2 for February, etc.,
-! and "iyear" is the year. If the year is 1968 AD, enter iyear=1968,
-! since iyear=68 would refer to 68 AD.
-! For BC years, iyear should be negative, so 45 BC would be iyear=-45.
-! By convention, there is no year 0 under the BC/AD year numbering
-! scheme. That is, years proceed as 2 BC, 1 BC, 1 AD, 2 AD, etc.,
-! without including 0. Subroutine calndr() will print an error message
-! and stop if you specify iyear=0.
-!
-! "idayct" is a day count. It is either the day number during the
-! specified year or the Julian Day number, depending on the value
-! of ioptn. By day number during the specified year, we mean
-! idayct=1 on 1 January, idayct=32 on 1 February, etc., to idayct=365
-! or 366 on 31 December, depending on whether the specified year
-! is a leap year.
-!
-! The values of input variables are not changed by this subroutine.
-!
-!
-! ALLOWABLE VALUES FOR "IOPTN" and the conversions they invoke.
-! Positive option values ( 1 to 5) use the standard Gregorian calendar.
-! Negative option values (-1 to -5) use the old Julian calendar.
-!
-! Absolute
-! value
-! of ioptn Input variable(s) Output variable(s)
-!
-! 1 iday,month,iyear idayct
-! Given a calendar date (iday,month,iyear), compute the day number
-! (idayct) during the year, where 1 January is day number 1 and
-! 31 December is day number 365 or 366, depending on whether it is
-! a leap year.
-!
-! 2 idayct,iyear iday,month
-! Given the day number of the year (idayct) and the year (iyear),
-! compute the day of the month (iday) and the month (month).
-!
-! 3 iday,month,iyear idayct
-! Given a calendar date (iday,month,iyear), compute the Julian Day
-! number (idayct) that starts at noon of the calendar date specified.
-!
-! 4 idayct iday,month,iyear
-! Given the Julian Day number (idayct) that starts at noon,
-! compute the corresponding calendar date (iday,month,iyear).
-!
-! 5 idayct iday,month,iyear
-! Given the Julian Day number (idayct) that starts at noon,
-! compute the corresponding day number for the year (iday)
-! and year (iyear). On return from calndr(), "month" will always
-! be set equal to 1 when ioptn=5.
-!
-! No inverse function is needed for ioptn=5 because it is
-! available through option 3. One simply calls calndr() with:
-! ioptn = 3,
-! iday = day number of the year instead of day of the month,
-! month = 1, and
-! iyear = whatever the desired year is.
-!
-!----------
-!
-! EXAMPLES
-! The first 6 examples are for the standard Gregorian calendar.
-! All the examples deal with 15 October 1582, which was the first day
-! of the Gregorian calendar. 15 October is the 288-th day of the year.
-! Julian Day number 2299161 began at noon on 15 October 1582.
-!
-! Find the day number during the year on 15 October 1582
-! ioptn = 1
-! call calndr (ioptn, 15, 10, 1582, idayct)
-! calndr() should return idayct=288
-!
-! Find the day of the month and month for day 288 in year 1582.
-! ioptn = 2
-! call calndr (ioptn, iday, month, 1582, 288)
-! calndr() should return iday=15 and month=10.
-!
-! Find the Julian Day number for 15 October 1582.
-! ioptn = 3
-! call calndr (ioptn, 15, 10, 1582, julian)
-! calndr() should return julian=2299161
-!
-! Find the Julian Day number for day 288 during 1582 AD.
-! When the input is day number of the year, one should specify month=1
-! ioptn = 3
-! call calndr (ioptn, 288, 1, 1582, julian)
-! calndr() should return dayct=2299161
-!
-! Find the date for Julian Day number 2299161.
-! ioptn = 4
-! call calndr (ioptn, iday, month, iyear, 2299161)
-! calndr() should return iday=15, month=10, and iyear=1582
-!
-! Find the day number during the year (iday) and year
-! for Julian Day number 2299161.
-! ioptn = 5
-! call calndr (ioptn, iday, month, iyear, 2299161)
-! calndr() should return iday=288, month=1, iyear=1582
-!
-! Given 15 October 1582 under the Gregorian calendar,
-! find the date (idayJ,imonthJ,iyearJ) under the Julian calendar.
-! To do this, we call calndr() twice, using the Julian Day number
-! as the intermediate value.
-! call calndr ( 3, 15, 10, 1582, julian)
-! call calndr (-4, idayJ, monthJ, iyearJ, julian)
-! The first call to calndr() should return julian=2299161, and
-! the second should return idayJ=5, monthJ=10, iyearJ=1582
-!
-!----------
-!
-! BASIC CALENDAR INFORMATION
-!
-! The Julian calendar was instituted by Julius Caesar in 45 BC.
-! Every fourth year is a leap year in which February has 29 days.
-! That is, the Julian calendar assumes that the year is exactly
-! 365.25 days long. Actually, the year is not quite this long.
-! The modern Gregorian calendar remedies this by omitting leap years
-! in years divisible by 100 except when the year is divisible by 400.
-! Thus, 1700, 1800, and 1900 are leap years under the Julian calendar
-! but not under the Gregorian calendar. The years 1600 and 2000 are
-! leap years under both the Julian and the Gregorian calendars.
-! Other years divisible by 4 are leap years under both calendars,
-! such as 1992, 1996, 2004, 2008, 2012, etc. For BC years, we recall
-! that year 0 was omitted, so 1 BC, 5 BC, 9 BC, 13 BC, etc., and 401 BC,
-! 801 BC, 1201 BC, etc., are leap years under both calendars, while
-! 101 BC, 201 BC, 301 BC, 501 BC, 601 BC, 701 BC, 901 BC, 1001 BC,
-! 1101 BC, etc., are leap years under the Julian calendar but not
-! the Gregorian calendar.
-!
-! The Gregorian calendar is named after Pope Gregory XIII. He declared
-! that the last day of the old Julian calendar would be Thursday,
-! 4 October 1582 and that the following day, Friday, would be reckoned
-! under the new calendar as 15 October 1582. The jump of 10 days was
-! included to make 21 March closer to the spring equinox.
-!
-! Only a few Catholic countries (Italy, Poland, Portugal, and Spain)
-! switched to the Gregorian calendar on the day after 4 October 1582.
-! It took other countries months to centuries to change to the
-! Gregorian calendar. For example, England's first day under the
-! Gregorian calendar was 14 September 1752. The same date applied to
-! the entire British empire, including America. Japan, Russia, and many
-! eastern European countries did not change to the Gregorian calendar
-! until the 20th century. The last country to change was Turkey,
-! which began using the Gregorian calendar on 1 January 1927.
-!
-! Therefore, between the years 1582 and 1926 AD, you must know
-! the country in which an event was dated to interpret the date
-! correctly. In Sweden, there was even a year (1712) when February
-! had 30 days. Consult a book on calendars for more details
-! about when various countries changed their calendars.
-!
-! DAY NUMBER DURING THE YEAR
-! The day number during the year is simply a counter equal to 1 on
-! 1 January, 32 on 1 February, etc., thorugh 365 or 366 on 31 December,
-! depending on whether the year is a leap year. Sometimes this is
-! called the Julian Day, but that term is better reserved for the
-! day counter explained below.
-!
-! JULIAN DAY NUMBER
-! The Julian Day numbering system was designed by Joseph Scaliger
-! in 1582 to remove ambiguity caused by varying calendar systems.
-! The name "Julian Day" was chosen to honor Scaliger's father,
-! Julius Caesar Scaliger (1484-1558), an Italian scholar and physician
-! who lived in France. Because Julian Day numbering was especially
-! designed for astronomers, Julian Days begin at noon so that the day
-! counter does not change in the middle of an astronmer's observing
-! period. Julian Day 0 began at noon on 1 January 4713 BC under the
-! Julian calendar. A modern reference point is that 23 May 1968
-! (Gregorian calendar) was Julian Day 2,440,000.
-!
-! JULIAN DAY NUMBER EXAMPLES
-!
-! The table below shows a few Julian Day numbers and their corresponding
-! dates, depending on which calendar is used. A negative 'iyear' refers
-! to BC (Before Christ).
-!
-! Julian Day under calendar:
-! iday month iyear Gregorian Julian
-! 24 11 -4714 0 -38
-! 1 1 -4713 38 0
-! 1 1 1 1721426 1721424
-! 4 10 1582 2299150 2299160
-! 15 10 1582 2299161 2299171
-! 1 3 1600 2305508 2305518
-! 23 5 1968 2440000 2440013
-! 5 7 1998 2451000 2451013
-! 1 3 2000 2451605 2451618
-! 1 1 2001 2451911 2451924
-!
-! From this table, we can see that the 10 day difference between the
-! two calendars in 1582 grew to 13 days by 1 March 1900, since 1900 was
-! a leap year under the Julian calendar but not under the Gregorian
-! calendar. The gap will widen to 14 days after 1 March 2100 for the
-! same reason.
-!
-!----------
-!
-! PORTABILITY
-!
-! This subroutine is written in standard FORTRAN 90.
-! It calls no external functions or subroutines and should run
-! without problem on any computer having a 32-bit word or longer.
-!
-!----------
-!
-! ALGORITHM
-!
-! The goal in coding calndr() was clear, clean code, not efficiency.
-! Calendar calculations usually take a trivial fraction of the time
-! in any program in which dates conversions are involved.
-! Data analysis usually takes the most time.
-!
-! Standard algorithms are followed in this subroutine. Internal to
-! this subroutine, we use a year counter "jyear" such that
-! jyear=iyear when iyear is positive
-! =iyear+1 when iyear is negative.
-! Thus, jyear does not experience a 1 year jump like iyear does
-! when going from BC to AD. Specifically, jyear=0 when iyear=-1,
-! i.e., when the year is 1 BC.
-!
-! For simplicity in dealing with February, inside this subroutine,
-! we let the year begin on 1 March so that the adjustable month,
-! February is the last month of the year.
-! It is clear that the calendar used to work this way because the
-! months September, October, November, and December refer to
-! 7, 8, 9, and 10. For consistency, jyear is incremented on 1 March
-! rather than on 1 January. Of course, everything is adjusted back to
-! standard practice of years beginning on 1 January before answers
-! are returned to the routine that calls calndr().
-!
-! Lastly, we use a trick to calculate the number of days from 1 March
-! until the end of the month that precedes the specified month.
-! That number of days is int(30.6001*(month+1))-122,
-! where 30.6001 is used to avoid the possibility of round-off and
-! truncation error. For example, if 30.6 were used instead,
-! 30.6*5 should be 153, but round-off error could make it 152.99999,
-! which would then truncated to 152, causing an error of 1 day.
-!
-! Algorithm reference:
-! Dershowitz, Nachum and Edward M. Reingold, 1990: Calendrical
-! Calculations. Software-Practice and Experience, vol. 20, number 9
-! (September 1990), pp. 899-928.
-!
-! Copyright (C) 1999 Jon Ahlquist.
-! Issued under the second GNU General Public License.
-! See www.gnu.org for details.
-! 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.
-! If you find any errors, please notify:
-! Jon Ahlquist <ahlquist at met.fsu.edu>
-! Dept of Meteorology
-! Florida State University
-! Tallahassee, FL 32306-4520
-! 15 March 1999.
-!
-!-----
-
-! converted to Fortran90 by Dimitri Komatitsch,
-! University of Pau, France, January 2008.
-
-! Declare internal variables.
- integer jdref, jmonth, jyear, leap, n1yr, n4yr, n100yr, n400yr, ndays, ndy400, ndy100, nyrs, yr400, yrref
-!
-! Explanation of all internal variables.
-! jdref Julian Day on which 1 March begins in the reference year.
-! jmonth Month counter which equals month+1 if month .gt. 2
-! or month+13 if month .le. 2.
-! jyear Year index, jyear=iyear if iyear .gt. 0, jyear=iyear+1
-! if iyear .lt. 0. Thus, jyear does not skip year 0
-! like iyear does between BC and AD years.
-! leap =1 if the year is a leap year, =0 if not.
-! n1yr Number of complete individual years between iyear and
-! the reference year after all 4, 100,
-! and 400 year periods have been removed.
-! n4yr Number of complete 4 year cycles between iyear and
-! the reference year after all 100 and 400 year periods
-! have been removed.
-! n100yr Number of complete 100 year periods between iyear and
-! the reference year after all 400 year periods
-! have been removed.
-! n400yr Number of complete 400 year periods between iyear and
-! the reference year.
-! ndays Number of days since 1 March during iyear. (In intermediate
-! steps, it holds other day counts as well.)
-! ndy400 Number of days in 400 years. Under the Gregorian calendar,
-! this is 400*365 + 100 - 3 = 146097. Under the Julian
-! calendar, this is 400*365 + 100 = 146100.
-! ndy100 Number of days in 100 years, Under the Gregorian calendar,
-! this is 100*365 + 24 = 36524. Under the Julian calendar,
-! this is 100*365 + 25 = 36525.
-! nyrs Number of years from the beginning of yr400
-! to the beginning of jyear. (Used for option +/-3).
-! yr400 The largest multiple of 400 years that is .le. jyear.
-!
-!
-!----------------------------------------------------------------
-! Do preparation work.
-!
-! Look for out-of-range option values.
- if ((ioptn == 0) .or. (abs(ioptn) >= 6)) then
- write(*,*)'For calndr(), you specified ioptn = ', ioptn
- write(*,*) 'Allowable values are 1 to 5 for the Gregorian calendar'
- write(*,*) 'and -1 to -5 for the Julian calendar.'
- stop
- endif
-!
-! Options 1-3 have "iyear" as an input value.
-! Internally, we use variable "jyear" that does not have a jump
-! from -1 (for 1 BC) to +1 (for 1 AD).
- if (abs(ioptn) <= 3) then
- if (iyear > 0) then
- jyear = iyear
- elseif (iyear == 0) then
- write(*,*) 'For calndr(), you specified the nonexistent year 0'
- stop
- else
- jyear = iyear + 1
- endif
-!
-! Set "leap" equal to 0 if "jyear" is not a leap year
-! and equal to 1 if it is a leap year.
- leap = 0
- if ((jyear/4)*4 == jyear) then
- leap = 1
- endif
- if ((ioptn > 0) .and. &
- ((jyear/100)*100 == jyear) .and. &
- ((jyear/400)*400 /= jyear) ) then
- leap = 0
- endif
- endif
-!
-! Options 3-5 involve Julian Day numbers, which need a reference year
-! and the Julian Days that began at noon on 1 March of the reference
-! year under the Gregorian and Julian calendars. Any year for which
-! "jyear" is divisible by 400 can be used as a reference year.
-! We chose 1600 AD as the reference year because it is the closest
-! multiple of 400 to the institution of the Gregorian calendar, making
-! it relatively easy to compute the Julian Day for 1 March 1600
-! given that, on 15 October 1582 under the Gregorian calendar,
-! the Julian Day was 2299161. Similarly, we need to do the same
-! calculation for the Julian calendar. We can compute this Julian
-! Day knwoing that on 4 October 1582 under the Julian calendar,
-! the Julian Day number was 2299160. The details of these calculations
-! is next.
-! From 15 October until 1 March, the number of days is the remainder
-! of October plus the days in November, December, January, and February:
-! 17+30+31+31+28 = 137, so 1 March 1583 under the Gregorian calendar
-! was Julian Day 2,299,298. Because of the 10 day jump ahead at the
-! switch from the Julian calendar to the Gregorian calendar, 1 March
-! 1583 under the Julian calendar was Julian Day 2,299,308. Making use
-! of the rules for the two calendar systems, 1 March 1600 was Julian
-! Day 2,299,298 + (1600-1583)*365 + 5 (due to leap years) =
-! 2,305,508 under the Gregorian calendar and day 2,305,518 under the
-! Julian calendar.
-! We also set the number of days in 400 years and 100 years.
-! For reference, 400 years is 146097 days under the Gregorian calendar
-! and 146100 days under the Julian calendar. 100 years is 36524 days
-! under the Gregorian calendar and 36525 days under the Julian calendar.
- if (abs(ioptn) >= 3) then
-!
-! Julian calendar values.
- yrref = 1600
- jdref = 2305518
-! = Julian Day reference value for the day that begins
-! at noon on 1 March of the reference year "yrref".
- ndy400 = 400*365 + 100
- ndy100 = 100*365 + 25
-!
-! Adjust for Gregorian calendar values.
- if (ioptn > 0) then
- jdref = jdref - 10
- ndy400 = ndy400 - 3
- ndy100 = ndy100 - 1
- endif
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -1 and +1:
-! Given a calendar date (iday,month,iyear), compute the day number
-! of the year (idayct), where 1 January is day number 1 and 31 December
-! is day number 365 or 366, depending on whether it is a leap year.
- if (abs(ioptn) == 1) then
-!
-! Compute the day number during the year.
- if (month <= 2) then
- idayct = iday + (month-1)*31
- else
- idayct = iday + int(30.6001 * (month+1)) - 63 + leap
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -2 and +2:
-! Given the day number of the year (idayct) and the year (iyear),
-! compute the day of the month (iday) and the month (month).
- elseif (abs(ioptn) == 2) then
-!
- if (idayct < 60+leap) then
- month = (idayct-1)/31
- iday = idayct - month*31
- month = month + 1
- else
- ndays = idayct - (60+leap)
-! = number of days past 1 March of the current year.
- jmonth = (10*(ndays+31))/306 + 3
-! = month counter, =4 for March, =5 for April, etc.
- iday = (ndays+123) - int(30.6001*jmonth)
- month = jmonth - 1
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -3 and +3:
-! Given a calendar date (iday,month,iyear), compute the Julian Day
-! number (idayct) that starts at noon.
- elseif (abs(ioptn) == 3) then
-!
-! Shift to a system where the year starts on 1 March, so January
-! and February belong to the preceding year.
-! Define jmonth=4 for March, =5 for April, ..., =15 for February.
- if (month <= 2) then
- jyear = jyear - 1
- jmonth = month + 13
- else
- jmonth = month + 1
- endif
-!
-! Find the closest multiple of 400 years that is .le. jyear.
- yr400 = (jyear/400)*400
-! = multiple of 400 years at or less than jyear.
- if (jyear < yr400) then
- yr400 = yr400 - 400
- endif
-!
- n400yr = (yr400 - yrref)/400
-! = number of 400-year periods from yrref to yr400.
- nyrs = jyear - yr400
-! = number of years from the beginning of yr400
-! to the beginning of jyear.
-!
-! Compute the Julian Day number.
- idayct = iday + int(30.6001*jmonth) - 123 + 365*nyrs + nyrs/4 &
- + jdref + n400yr*ndy400
-!
-! If we are using the Gregorian calendar, we must not count
-! every 100-th year as a leap year. nyrs is less than 400 years,
-! so we do not need to consider the leap year that would occur if
-! nyrs were divisible by 400, i.e., we do not add nyrs/400.
- if (ioptn > 0) then
- idayct = idayct - nyrs/100
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -5, -4, +4, and +5:
-! Given the Julian Day number (idayct) that starts at noon,
-! compute the corresponding calendar date (iday,month,iyear)
-! (abs(ioptn)=4) or day number during the year (abs(ioptn)=5).
- else
-!
-! Create a new reference date which begins on the nearest
-! 400-year cycle less than or equal to the Julian Day for 1 March
-! in the year in which the given Julian Day number (idayct) occurs.
- ndays = idayct - jdref
- n400yr = ndays / ndy400
-! = integral number of 400-year periods separating
-! idayct and the reference date, jdref.
- jdref = jdref + n400yr*ndy400
- if (jdref > idayct) then
- n400yr = n400yr - 1
- jdref = jdref - ndy400
- endif
-!
- ndays = idayct - jdref
-! = number from the reference date to idayct.
-!
- n100yr = min(ndays/ndy100, 3)
-! = number of complete 100-year periods
-! from the reference year to the current year.
-! The min() function is necessary to avoid n100yr=4
-! on 29 February of the last year in the 400-year cycle.
-!
- ndays = ndays - n100yr*ndy100
-! = remainder after removing an integral number of
-! 100-year periods.
-!
- n4yr = ndays / 1461
-! = number of complete 4-year periods in the current century.
-! 4 years consists of 4*365 + 1 = 1461 days.
-!
- ndays = ndays - n4yr*1461
-! = remainder after removing an integral number
-! of 4-year periods.
-!
- n1yr = min(ndays/365, 3)
-! = number of complete years since the last leap year.
-! The min() function is necessary to avoid n1yr=4
-! when the date is 29 February on a leap year,
-! in which case ndays=1460, and 1460/365 = 4.
-!
- ndays = ndays - 365*n1yr
-! = number of days so far in the current year,
-! where ndays=0 on 1 March.
-!
- iyear = n1yr + 4*n4yr + 100*n100yr + 400*n400yr + yrref
-! = year, as counted in the standard way,
-! but relative to 1 March.
-!
-! At this point, we need to separate ioptn=abs(4), which seeks a
-! calendar date, and ioptn=abs(5), which seeks the day number during
-! the year. First compute the calendar date if desired (abs(ioptn)=4).
- if (abs(ioptn) == 4) then
- jmonth = (10*(ndays+31))/306 + 3
-! = offset month counter. jmonth=4 for March, =13 for
-! December, =14 for January, =15 for February.
- iday = (ndays+123) - int(30.6001*jmonth)
-! = day of the month, starting with 1 on the first day
-! of the month.
-!
-! Now adjust for the fact that the year actually begins
-! on 1 January.
- if (jmonth <= 13) then
- month = jmonth - 1
- else
- month = jmonth - 13
- iyear = iyear + 1
- endif
-!
-! This code handles abs(ioptn)=5, finding the day number during the year.
- else
-! ioptn=5 always returns month=1, which we set now.
- month = 1
-!
-! We need to determine whether this is a leap year.
- leap = 0
- if ((jyear/4)*4 == jyear) then
- leap = 1
- endif
- if ((ioptn > 0) .and. &
- ((jyear/100)*100 == jyear) .and. &
- ((jyear/400)*400 /= jyear) ) then
- leap = 0
- endif
-!
-! Now find the day number "iday".
-! ndays is the number of days since the most recent 1 March,
-! so ndays=0 on 1 March.
- if (ndays <=305) then
- iday = ndays + 60 + leap
- else
- iday = ndays - 305
- iyear = iyear + 1
- endif
- endif
-!
-! Adjust the year if it is .le. 0, and hence BC (Before Christ).
- if (iyear <= 0) then
- iyear = iyear - 1
- endif
-!
-! End the code for the last option, ioptn.
- endif
-
- end subroutine calndr
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_1D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_1D.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_1D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,582 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! code to check that all the internal MPI 1D buffers are okay
-! inside any given chunk, along both xi and eta
-! we compare the coordinates of the points in the buffers
-
- program check_buffers_1D
-
- implicit none
-
- include "constants.h"
-
- integer ithisproc,iotherproc
- integer ipoin
-
- double precision diff
-
- integer npoin1D_mesher,npoin1D
-
-! for addressing of the slices
- integer ichunk,iproc_xi,iproc_eta,iproc,icorners,iregion_code
- integer iproc_read
- integer, dimension(:,:,:), allocatable :: addressing
-
-! 1D addressing for copy of edges between slices
-! we add one to the size of the array for the final flag
- integer, dimension(:), allocatable :: iboolleft,iboolright
- double precision, dimension(:), allocatable :: xleft,yleft,zleft,xright,yright,zright
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, &
- NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE,REFERENCE_1D_MODEL, &
- THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- 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
-
-! this is for all the regions
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- nglob
-
-! computed in read_compute_parameters
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-! processor identification
- character(len=150) prname,prname_other
-
- integer :: NGLOB1D_RADIAL_MAX
- 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(NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_SPEC_THIS
- integer, dimension(NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_SPEC_OTHER
-! ************** PROGRAM STARTS HERE **************
-
- print *
- print *,'Check all MPI buffers along xi and eta inside each chunk'
- print *
-
-! read the parameter file and compute additional parameters
- call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
- print *
- print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
- print *,'There are ',NCHUNKS,' chunks'
- print *,'There are ',NPROC_XI,' slices along xi in each chunk'
- print *,'There are ',NPROC_ETA,' slices along eta in each chunk'
- print *
-
-! dynamic memory allocation for arrays
- allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1))
-
-! open file with global slice number addressing
- print *,'reading slice addressing'
- open(unit=34,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read')
- do iproc = 0,NPROCTOT-1
- read(34,*) iproc_read,ichunk,iproc_xi,iproc_eta
- if(iproc_read /= iproc) stop 'incorrect slice number read'
- addressing(ichunk,iproc_xi,iproc_eta) = iproc
- enddo
- close(34)
-
-! loop over all the regions of the mesh
- do iregion_code = 1,MAX_NUM_REGIONS
-
- print *
- print *,' ********* checking region ',iregion_code,' *********'
- print *
-
- NGLOB1D_RADIAL_CORNER(iregion_code,:) = NGLOB1D_RADIAL(iregion_code)
- NGLOB1D_RADIAL_MAX = NGLOB1D_RADIAL(iregion_code)
- if (iregion_code == IREGION_OUTER_CORE .and. (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
- NGLOB1D_RADIAL_MAX = NGLOB1D_RADIAL_MAX + maxval(DIFF_NSPEC1D_RADIAL(:,:))*(NGLLZ-1)
- endif
-
-! dynamic memory allocation for arrays
- allocate(iboolleft(NGLOB1D_RADIAL_MAX+1))
- allocate(iboolright(NGLOB1D_RADIAL_MAX+1))
- allocate(xleft(NGLOB1D_RADIAL_MAX+1))
- allocate(yleft(NGLOB1D_RADIAL_MAX+1))
- allocate(zleft(NGLOB1D_RADIAL_MAX+1))
- allocate(xright(NGLOB1D_RADIAL_MAX+1))
- allocate(yright(NGLOB1D_RADIAL_MAX+1))
- allocate(zright(NGLOB1D_RADIAL_MAX+1))
-
-! ********************************************************
-! *************** check along xi
-! ********************************************************
-
-! loop for both corners for 1D buffers
- do icorners=1,2
-
- print *
- print *,'Checking for xi in set of corners # ',icorners
- print *
-
-! loop on the chunks
- do ichunk = 1,NCHUNKS
-
- print *
- print *,'Checking xi in chunk ',ichunk
- print *
-
-! double loop on NPROC_XI and NPROC_ETA
- do iproc_eta=0,NPROC_ETA-1
-
- print *,'checking row ',iproc_eta
-
- do iproc_xi=0,NPROC_XI-2
-
- print *,'checking slice ixi = ',iproc_xi,' in that row'
-
- ithisproc = addressing(ichunk,iproc_xi,iproc_eta)
- iotherproc = addressing(ichunk,iproc_xi+1,iproc_eta)
-
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_CORNER(iregion_code,:)
- if (iregion_code==IREGION_OUTER_CORE) then
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_xi,2) == 0) then
- if (mod(iproc_eta,2) == 0) then
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- else
- if (mod(iproc_eta,2) == 0) then
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
- endif
- endif
- else
- if (mod(iproc_xi,2) == 0) then
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_eta,2) == 0) then
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- endif
- endif
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_CORNER(iregion_code,:)
- if (iregion_code==IREGION_OUTER_CORE) then
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_xi+1,2) == 0) then
- if (mod(iproc_eta,2) == 0) then
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- else
- if (mod(iproc_eta,2) == 0) then
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
- endif
- endif
- else
- if (mod(iproc_xi+1,2) == 0) then
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_eta,2) == 0) then
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- endif
- endif
-! create the name for the database of the current slide
- call create_serial_name_database(prname,ithisproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
- call create_serial_name_database(prname_other,iotherproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
-
-! read 1D addressing buffers for copy between slices along xi with MPI
-
- if(icorners == 1) then
-! read ibool1D_rightxi_lefteta of this slice
- write(*,*) 'reading MPI 1D buffer ibool1D_rightxi_lefteta slice ',ithisproc
- open(unit=34,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='old',action='read')
- else if(icorners == 2) then
-! read ibool1D_rightxi_righteta of this slice
- write(*,*) 'reading MPI 1D buffer ibool1D_rightxi_righteta slice ',ithisproc
- open(unit=34,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='old',action='read')
- else
- stop 'incorrect corner number'
- endif
-
- npoin1D = 1
- 360 continue
- read(34,*) iboolright(npoin1D),xright(npoin1D),yright(npoin1D),zright(npoin1D)
- if(iboolright(npoin1D) > 0) then
- npoin1D = npoin1D + 1
- goto 360
- endif
- npoin1D = npoin1D - 1
- write(*,*) 'found ',npoin1D,' points in iboolright slice ',ithisproc
- read(34,*) npoin1D_mesher
- if(icorners == 1) then
- if(npoin1D /= NGLOB1D_RADIAL_SPEC_THIS(2)) stop 'incorrect iboolright read'
- else
- if(npoin1D /= NGLOB1D_RADIAL_SPEC_THIS(3)) stop 'incorrect iboolright read'
- endif
- close(34)
-
- if(icorners == 1) then
-! read ibool1D_leftxi_lefteta of other slice
- write(*,*) 'reading MPI 1D buffer ibool1D_leftxi_lefteta slice ',iotherproc
- open(unit=34,file=prname_other(1:len_trim(prname_other))//'ibool1D_leftxi_lefteta.txt',status='old',action='read')
- else if(icorners == 2) then
-! read ibool1D_leftxi_righteta of other slice
- write(*,*) 'reading MPI 1D buffer ibool1D_leftxi_righteta slice ',iotherproc
- open(unit=34,file=prname_other(1:len_trim(prname_other))//'ibool1D_leftxi_righteta.txt',status='old',action='read')
- else
- stop 'incorrect corner number'
- endif
-
- npoin1D = 1
- 350 continue
- read(34,*) iboolleft(npoin1D),xleft(npoin1D),yleft(npoin1D),zleft(npoin1D)
- if(iboolleft(npoin1D) > 0) then
- npoin1D = npoin1D + 1
- goto 350
- endif
- npoin1D = npoin1D - 1
- write(*,*) 'found ',npoin1D,' points in iboolleft slice ',iotherproc
- read(34,*) npoin1D_mesher
- if(icorners == 1) then
- if(npoin1D /= NGLOB1D_RADIAL_SPEC_OTHER(1)) stop 'incorrect iboolleft read'
- else
- if(npoin1D /= NGLOB1D_RADIAL_SPEC_OTHER(4)) stop 'incorrect iboolleft read'
- endif
- close(34)
-
-! check the coordinates of all the points in the buffer
-! to see if it is correctly sorted
- do ipoin = 1,npoin1D
- diff = dmax1(dabs(xleft(ipoin)-xright(ipoin)), &
- dabs(yleft(ipoin)-yright(ipoin)),dabs(zleft(ipoin)-zright(ipoin)))
- if(diff > 0.0000001d0) then
- print *,'different: ',ipoin,iboolleft(ipoin),iboolright(ipoin),diff
- stop 'error: different'
- endif
- enddo
-
- enddo
- enddo
- enddo
-
- enddo
-
-
-! ********************************************************
-! *************** check along eta
-! ********************************************************
-
-! added loop for both corners for 1D buffers
- do icorners=1,2
-
- print *
- print *,'Checking for eta in set of corners # ',icorners
- print *
-
-! loop on the chunks
- do ichunk = 1,NCHUNKS
-
- print *
- print *,'Checking eta in chunk ',ichunk
- print *
-
-! double loop on NPROC_XI and NPROC_ETA
- do iproc_xi=0,NPROC_XI-1
-
- print *,'checking row ',iproc_xi
-
- do iproc_eta=0,NPROC_ETA-2
-
- print *,'checking slice ieta = ',iproc_eta,' in that row'
-
- ithisproc = addressing(ichunk,iproc_xi,iproc_eta)
- iotherproc = addressing(ichunk,iproc_xi,iproc_eta+1)
-
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_CORNER(iregion_code,:)
- if (iregion_code==IREGION_OUTER_CORE) then
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_xi,2) == 0) then
- if (mod(iproc_eta,2) == 0) then
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- else
- if (mod(iproc_eta,2) == 0) then
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
- endif
- endif
- else
- if (mod(iproc_xi,2) == 0) then
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_eta,2) == 0) then
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- endif
- endif
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_CORNER(iregion_code,:)
- if (iregion_code==IREGION_OUTER_CORE) then
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_xi,2) == 0) then
- if (mod(iproc_eta+1,2) == 0) then
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- else
- if (mod(iproc_eta+1,2) == 0) then
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
- endif
- endif
- else
- if (mod(iproc_xi,2) == 0) then
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_eta+1,2) == 0) then
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- endif
- endif
-! create the name for the database of the current slide
- call create_serial_name_database(prname,ithisproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
- call create_serial_name_database(prname_other,iotherproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
-
-! read 1D addressing buffers for copy between slices along xi with MPI
-
- if(icorners == 1) then
-! read ibool1D_leftxi_righteta of this slice
- write(*,*) 'reading MPI 1D buffer ibool1D_leftxi_righteta slice ',ithisproc
- open(unit=34,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='old',action='read')
- else if(icorners == 2) then
-! read ibool1D_rightxi_righteta of this slice
- write(*,*) 'reading MPI 1D buffer ibool1D_rightxi_righteta slice ',ithisproc
- open(unit=34,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='old',action='read')
- else
- stop 'incorrect corner number'
- endif
-
- npoin1D = 1
- 460 continue
- read(34,*) iboolright(npoin1D),xright(npoin1D),yright(npoin1D),zright(npoin1D)
- if(iboolright(npoin1D) > 0) then
- npoin1D = npoin1D + 1
- goto 460
- endif
- npoin1D = npoin1D - 1
- write(*,*) 'found ',npoin1D,' points in iboolright slice ',ithisproc
- read(34,*) npoin1D_mesher
-
- if(icorners == 1) then
- if(npoin1D /= NGLOB1D_RADIAL_SPEC_THIS(4)) stop 'incorrect iboolright read'
- else
- if(npoin1D /= NGLOB1D_RADIAL_SPEC_THIS(3)) stop 'incorrect iboolright read'
- endif
- close(34)
-
- if(icorners == 1) then
-! read ibool1D_leftxi_lefteta of other slice
- write(*,*) 'reading MPI 1D buffer ibool1D_leftxi_lefteta slice ',iotherproc
- open(unit=34,file=prname_other(1:len_trim(prname_other))//'ibool1D_leftxi_lefteta.txt',status='old',action='read')
- else if(icorners == 2) then
-! read ibool1D_rightxi_lefteta of other slice
- write(*,*) 'reading MPI 1D buffer ibool1D_rightxi_lefteta slice ',iotherproc
- open(unit=34,file=prname_other(1:len_trim(prname_other))//'ibool1D_rightxi_lefteta.txt',status='old',action='read')
- else
- stop 'incorrect corner number'
- endif
-
- npoin1D = 1
- 450 continue
- read(34,*) iboolleft(npoin1D),xleft(npoin1D),yleft(npoin1D),zleft(npoin1D)
- if(iboolleft(npoin1D) > 0) then
- npoin1D = npoin1D + 1
- goto 450
- endif
- npoin1D = npoin1D - 1
- write(*,*) 'found ',npoin1D,' points in iboolleft slice ',iotherproc
- read(34,*) npoin1D_mesher
-
- if(icorners == 1) then
- if(npoin1D /= NGLOB1D_RADIAL_SPEC_OTHER(1)) stop 'incorrect iboolleft read'
- else
- if(npoin1D /= NGLOB1D_RADIAL_SPEC_OTHER(2)) stop 'incorrect iboolleft read'
- endif
- close(34)
-
-! check the coordinates of all the points in the buffer
-! to see if it is correctly sorted
- do ipoin = 1,npoin1D
- diff = dmax1(dabs(xleft(ipoin)-xright(ipoin)), &
- dabs(yleft(ipoin)-yright(ipoin)),dabs(zleft(ipoin)-zright(ipoin)))
- if(diff > 0.0000001d0) then
- print *,'different: ',ipoin,iboolleft(ipoin),iboolright(ipoin),diff
- stop 'error: different'
- endif
- enddo
-
- enddo
- enddo
- enddo
-
- enddo
-
-! deallocate arrays
- deallocate(iboolleft)
- deallocate(iboolright)
- deallocate(xleft)
- deallocate(yleft)
- deallocate(zleft)
- deallocate(xright)
- deallocate(yright)
- deallocate(zright)
-
- enddo
-
- print *
- print *,'done'
- print *
-
- end program check_buffers_1D
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_2D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_2D.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_2D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,404 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! code to check that all the internal MPI buffers are okay
-! inside any given chunk, along both xi and eta
-! we compare the coordinates of the points in the buffers
-
- program check_buffers_2D
-
- implicit none
-
- include "constants.h"
-
- integer ithisproc,iotherproc
-
- integer ipoin
-
- integer npoin2d_xi_save,npoin2d_xi_mesher,npoin2d_xi
- integer npoin2d_eta_save,npoin2d_eta_mesher,npoin2d_eta
-
-! for addressing of the slices
- integer ichunk,iproc_xi,iproc_eta,iproc
- integer iproc_read,iregion_code
- integer, dimension(:,:,:), allocatable :: addressing
-
- double precision diff
-
-! 2-D addressing and buffers for summation between slices
- integer, dimension(:), allocatable :: iboolleft_xi,iboolright_xi, &
- iboolleft_eta,iboolright_eta
-
-! coordinates of the points to compare
- double precision, dimension(:), allocatable :: xleft_xi,yleft_xi,zleft_xi, &
- xright_xi,yright_xi,zright_xi,xleft_eta,yleft_eta,zleft_eta, &
- xright_eta,yright_eta,zright_eta
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- 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
-
-! 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
-
- 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
-
-! now this is 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
-
-! processor identification
- character(len=150) prname,prname_other
-
- 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 **************
-
- print *
- print *,'Check all MPI buffers along xi and eta inside each chunk'
- print *
-
-! read the parameter file and compute additional parameters
-
- call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
-
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
- print *
- print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
- print *,'There are ',NCHUNKS,' chunks'
- print *,'There are ',NPROC_XI,' slices along xi in each chunk'
- print *,'There are ',NPROC_ETA,' slices along eta in each chunk'
- print *
-
-! dynamic memory allocation for arrays
- allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1))
-
-! open file with global slice number addressing
- print *,'reading slice addressing'
- open(unit=34,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read')
- do iproc = 0,NPROCTOT-1
- read(34,*) iproc_read,ichunk,iproc_xi,iproc_eta
- if(iproc_read /= iproc) stop 'incorrect slice number read'
- addressing(ichunk,iproc_xi,iproc_eta) = iproc
- enddo
- close(34)
-
-! loop over all the regions of the mesh
- do iregion_code = 1,MAX_NUM_REGIONS
-
- print *
- print *,' ********* checking region ',iregion_code,' *********'
- print *
-
-! dynamic memory allocation for arrays
- allocate(iboolleft_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
- allocate(iboolright_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
- allocate(iboolleft_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
- allocate(iboolright_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
- allocate(xleft_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
- allocate(yleft_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
- allocate(zleft_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
- allocate(xright_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
- allocate(yright_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
- allocate(zright_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
- allocate(xleft_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
- allocate(yleft_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
- allocate(zleft_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
- allocate(xright_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
- allocate(yright_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
- allocate(zright_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
-
-! loop on the chunks
- do ichunk = 1,NCHUNKS
-
- print *
- print *,'Checking xi in chunk ',ichunk
- print *
-
-! double loop on NPROC_XI and NPROC_ETA
- do iproc_eta=0,NPROC_ETA-1
-
- print *,'checking row ',iproc_eta
-
- do iproc_xi=0,NPROC_XI-2
-
- print *,'checking slice ixi = ',iproc_xi,' in that row'
-
- ithisproc = addressing(ichunk,iproc_xi,iproc_eta)
- iotherproc = addressing(ichunk,iproc_xi+1,iproc_eta)
-
-! create the name for the database of the current slide
- call create_serial_name_database(prname,ithisproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
- call create_serial_name_database(prname_other,iotherproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
-
-! read 2-D addressing for summation between slices along xi with MPI
-
-! read iboolright_xi of this slice
- write(*,*) 'reading MPI buffer iboolright_xi slice ',ithisproc
- open(unit=34,file=prname(1:len_trim(prname))//'iboolright_xi.txt',status='old',action='read')
- npoin2D_xi = 1
- 360 continue
- read(34,*) iboolright_xi(npoin2D_xi), &
- xright_xi(npoin2D_xi),yright_xi(npoin2D_xi),zright_xi(npoin2D_xi)
- if(iboolright_xi(npoin2D_xi) > 0) then
- npoin2D_xi = npoin2D_xi + 1
- goto 360
- endif
- npoin2D_xi = npoin2D_xi - 1
- write(*,*) 'found ',npoin2D_xi,' points in iboolright_xi slice ',ithisproc
- read(34,*) npoin2D_xi_mesher
- if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX(iregion_code) .or. npoin2D_xi /= npoin2D_xi_mesher) then
- stop 'incorrect iboolright_xi read'
- endif
- close(34)
-
-! save to compare to other side
- npoin2D_xi_save = npoin2D_xi
-
-! read iboolleft_xi of other slice
- write(*,*) 'reading MPI buffer iboolleft_xi slice ',iotherproc
- open(unit=34,file=prname_other(1:len_trim(prname_other))//'iboolleft_xi.txt',status='old',action='read')
- npoin2D_xi = 1
- 350 continue
- read(34,*) iboolleft_xi(npoin2D_xi), &
- xleft_xi(npoin2D_xi),yleft_xi(npoin2D_xi),zleft_xi(npoin2D_xi)
- if(iboolleft_xi(npoin2D_xi) > 0) then
- npoin2D_xi = npoin2D_xi + 1
- goto 350
- endif
- npoin2D_xi = npoin2D_xi - 1
- write(*,*) 'found ',npoin2D_xi,' points in iboolleft_xi slice ',iotherproc
- read(34,*) npoin2D_xi_mesher
- if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX(iregion_code) .or. npoin2D_xi /= npoin2D_xi_mesher) then
- stop 'incorrect iboolleft_xi read'
- endif
- close(34)
-
- if(npoin2D_xi_save == npoin2D_xi) then
- print *,'okay, same size for both buffers'
- else
- stop 'wrong buffer size'
- endif
-
-! check the coordinates of all the points in the buffer
-! to see if it is correctly sorted
- do ipoin = 1,npoin2D_xi
- diff = dmax1(dabs(xleft_xi(ipoin)-xright_xi(ipoin)), &
- dabs(yleft_xi(ipoin)-yright_xi(ipoin)),dabs(zleft_xi(ipoin)-zright_xi(ipoin)))
- if(diff > 0.0000001d0) print *,'different: ',ipoin,iboolleft_xi(ipoin),iboolright_xi(ipoin),diff
- enddo
-
- enddo
- enddo
- enddo
-
-
-! loop on the chunks
- do ichunk = 1,NCHUNKS
-
- print *
- print *,'Checking eta in chunk ',ichunk
- print *
-
-! double loop on NPROC_XI and NPROC_ETA
- do iproc_xi=0,NPROC_XI-1
-
- print *,'checking row ',iproc_xi
-
- do iproc_eta=0,NPROC_ETA-2
-
- print *,'checking slice ieta = ',iproc_eta,' in that row'
-
- ithisproc = addressing(ichunk,iproc_xi,iproc_eta)
- iotherproc = addressing(ichunk,iproc_xi,iproc_eta+1)
-
-! create the name for the database of the current slide
- call create_serial_name_database(prname,ithisproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
- call create_serial_name_database(prname_other,iotherproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
-
-! read 2-D addressing for summation between slices along xi with MPI
-
-! read iboolright_eta of this slice
- write(*,*) 'reading MPI buffer iboolright_eta slice ',ithisproc
- open(unit=34,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='old',action='read')
- npoin2D_eta = 1
- 460 continue
- read(34,*) iboolright_eta(npoin2D_eta), &
- xright_eta(npoin2D_eta),yright_eta(npoin2D_eta),zright_eta(npoin2D_eta)
- if(iboolright_eta(npoin2D_eta) > 0) then
- npoin2D_eta = npoin2D_eta + 1
- goto 460
- endif
- npoin2D_eta = npoin2D_eta - 1
- write(*,*) 'found ',npoin2D_eta,' points in iboolright_eta slice ',ithisproc
- read(34,*) npoin2D_eta_mesher
- if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX(iregion_code) .or. npoin2D_eta /= npoin2D_eta_mesher) then
- stop 'incorrect iboolright_eta read'
- endif
- close(34)
-
-! save to compare to other side
- npoin2D_eta_save = npoin2D_eta
-
-! read iboolleft_eta of other slice
- write(*,*) 'reading MPI buffer iboolleft_eta slice ',iotherproc
- open(unit=34,file=prname_other(1:len_trim(prname_other))//'iboolleft_eta.txt',status='old',action='read')
- npoin2D_eta = 1
- 450 continue
- read(34,*) iboolleft_eta(npoin2D_eta), &
- xleft_eta(npoin2D_eta),yleft_eta(npoin2D_eta),zleft_eta(npoin2D_eta)
- if(iboolleft_eta(npoin2D_eta) > 0) then
- npoin2D_eta = npoin2D_eta + 1
- goto 450
- endif
- npoin2D_eta = npoin2D_eta - 1
- write(*,*) 'found ',npoin2D_eta,' points in iboolleft_eta slice ',iotherproc
- read(34,*) npoin2D_eta_mesher
- if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX(iregion_code) .or. npoin2D_eta /= npoin2D_eta_mesher) then
- stop 'incorrect iboolleft_eta read'
- endif
- close(34)
-
- if(npoin2D_eta_save == npoin2D_eta) then
- print *,'okay, same size for both buffers'
- else
- stop 'wrong buffer size'
- endif
-
-! check the coordinates of all the points in the buffer
-! to see if it is correctly sorted
- do ipoin = 1,npoin2D_eta
- diff = dmax1(dabs(xleft_eta(ipoin)-xright_eta(ipoin)), &
- dabs(yleft_eta(ipoin)-yright_eta(ipoin)),dabs(zleft_eta(ipoin)-zright_eta(ipoin)))
- if(diff > 0.0000001d0) print *,'different: ',ipoin,iboolleft_eta(ipoin),iboolright_eta(ipoin),diff
- enddo
-
- enddo
- enddo
- enddo
-
-! deallocate arrays
- deallocate(iboolleft_xi)
- deallocate(iboolright_xi)
- deallocate(iboolleft_eta)
- deallocate(iboolright_eta)
- deallocate(xleft_xi)
- deallocate(yleft_xi)
- deallocate(zleft_xi)
- deallocate(xright_xi)
- deallocate(yright_xi)
- deallocate(zright_xi)
- deallocate(xleft_eta)
- deallocate(yleft_eta)
- deallocate(zleft_eta)
- deallocate(xright_eta)
- deallocate(yright_eta)
- deallocate(zright_eta)
-
- enddo
-
- print *
- print *,'done'
- print *
-
- end program check_buffers_2D
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_corners_chunks.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_corners_chunks.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_corners_chunks.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,293 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! code to check that all the 1D buffers between chunk corners are okay
-
- program check_buffers_corners_chunks
-
- implicit none
-
- include "constants.h"
-
- integer imsg
- integer ipoin1D
- integer iboolmaster,iboolworker1,iboolworker2
- integer npoin1D_master,npoin1D_worker1,npoin1D_worker2
- integer iregion_code,iproc
-
-! number of corners between chunks
- integer NCORNERSCHUNKS
-
- double precision xmaster,ymaster,zmaster
- double precision xworker1,yworker1,zworker1
- double precision xworker2,yworker2,zworker2
- double precision diff1,diff2
-
-! communication pattern for corners between chunks
- integer, dimension(:), allocatable :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- 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
-
-! this is 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
-
- character(len=150) filename,prname
-
-! computed in read_compute_parameters
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
- integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
-! ************** PROGRAM STARTS HERE **************
-
- print *
- print *,'Check all MPI buffers between chunk corners'
- print *
-
-! read the parameter file and compute additional parameters
- call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
-
- print *
- print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
- print *,'There are ',NCHUNKS,' chunks'
- print *,'There are ',NPROC_XI,' slices along xi in each chunk'
- print *,'There are ',NPROC_ETA,' slices along eta in each chunk'
- print *
-
-! number of corners shared between chunks
- if(NCHUNKS == 1 .or. NCHUNKS == 2 .or. NCHUNKS == 3) then
- NCORNERSCHUNKS = 1
- else if(NCHUNKS == 6) then
- NCORNERSCHUNKS = 8
- else
- stop 'number of chunks must be either 1, 2, 3 or 6'
- endif
-
- if(NCHUNKS == 1) stop 'only one chunk, nothing to check'
-
- print *,'There are ',NCORNERSCHUNKS,' messages to assemble all the corners'
- print *
-
-! allocate array for messages for corners
- allocate(iproc_master_corners(NCORNERSCHUNKS))
- allocate(iproc_worker1_corners(NCORNERSCHUNKS))
- allocate(iproc_worker2_corners(NCORNERSCHUNKS))
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! 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
- 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) &
- stop 'incorrect chunk corner numbering'
- enddo
- close(IIN)
-
-! loop over all the regions of the mesh
- do iregion_code = 1,MAX_NUM_REGIONS
-
- print *
- print *,' ********* checking region ',iregion_code,' *********'
- print *
-
-! loop on all the messages between corners
- do imsg = 1,NCORNERSCHUNKS
-
- print *
- print *,'Checking message ',imsg,' out of ',NCORNERSCHUNKS
-
-! read 1-D buffers for the corners
-
-! master
- write(filename,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
- iproc = iproc_master_corners(imsg)
- call create_serial_name_database(prname,iproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
- open(unit=34,file=prname(1:len_trim(prname))//filename,status='old',action='read')
-
-! first worker
- write(filename,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
- iproc = iproc_worker1_corners(imsg)
- call create_serial_name_database(prname,iproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
- open(unit=35,file=prname(1:len_trim(prname))//filename,status='old',action='read')
-
-! second worker
-! if only two chunks then there is no second worker
- if(NCHUNKS /= 2) then
- write(filename,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
- iproc = iproc_worker2_corners(imsg)
- call create_serial_name_database(prname,iproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
- open(unit=36,file=prname(1:len_trim(prname))//filename,status='old',action='read')
- endif
-
- write(*,*) 'reading MPI 1D buffers for 3 procs corner'
-
- read(34,*) npoin1D_master
- read(35,*) npoin1D_worker1
-! if only two chunks then there is no second worker
- if(NCHUNKS /= 2) then
- read(36,*) npoin1D_worker2
- else
- npoin1D_worker2 = npoin1D_worker1
- endif
-
- if(npoin1D_master /= NGLOB1D_RADIAL(iregion_code) .or. &
- npoin1D_worker1 /= NGLOB1D_RADIAL(iregion_code) .or. &
- npoin1D_worker2 /= NGLOB1D_RADIAL(iregion_code)) then
- stop 'incorrect total number of points'
- else
- print *,'number of points is correct: ',NGLOB1D_RADIAL(iregion_code)
- endif
-
-! check all the points based upon their coordinates
- do ipoin1D = 1, NGLOB1D_RADIAL(iregion_code)
-
- read(34,*) iboolmaster,xmaster,ymaster,zmaster
- read(35,*) iboolworker1,xworker1,yworker1,zworker1
-! if only two chunks then there is no second worker
- if(NCHUNKS /= 2) read(36,*) iboolworker2,xworker2,yworker2,zworker2
-
- diff1 = dmax1(dabs(xmaster-xworker1),dabs(ymaster-yworker1),dabs(zmaster-zworker1))
- if(diff1 > 0.0000001d0) then
- print *,'different : ',ipoin1D,iboolmaster,iboolworker1,diff1
- print *,'xmaster,xworker1 = ',xmaster,xworker1
- print *,'ymaster,yworker1 = ',ymaster,yworker1
- print *,'zmaster,zworker1 = ',zmaster,zworker1
- stop 'error: different'
- endif
-
-! if only two chunks then there is no second worker
- if(NCHUNKS /= 2) then
- diff2 = dmax1(dabs(xmaster-xworker2),dabs(ymaster-yworker2),dabs(zmaster-zworker2))
- if(diff2 > 0.0000001d0) then
- print *,'different : ',ipoin1D,iboolmaster,iboolworker2,diff2
- print *,'xmaster,xworker2 = ',xmaster,xworker2
- print *,'ymaster,yworker2 = ',ymaster,yworker2
- print *,'zmaster,zworker2 = ',zmaster,zworker2
- stop 'error: different'
- endif
- endif
-
- enddo
-
- close(34)
- close(35)
-! if only two chunks then there is no second worker
- if(NCHUNKS /= 2) close(36)
-
- enddo
-
- enddo
-
- print *
- print *,'done'
- print *
-
- end program check_buffers_corners_chunks
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_faces_chunks.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_faces_chunks.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_faces_chunks.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,262 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! code to check that all the 2D buffers between chunk faces are okay
-
- program check_buffers_faces_chunks
-
- implicit none
-
- include "constants.h"
-
- integer imsg
-
- integer npoin2D_sender,npoin2D_receiver
- integer iboolsend,iboolreceive,ipoin2D
- integer iregion_code,iproc
-
-! number of faces between chunks
- integer NUM_FACES,NUMMSGS_FACES
-
-! number of message types
- integer NUM_MSG_TYPES
-
- double precision xsend,ysend,zsend
- double precision xreceive,yreceive,zreceive
- double precision diff
-
- integer NPROC_ONE_DIRECTION
-
-! communication pattern for faces between chunks
- integer, dimension(:), allocatable :: iprocfrom_faces,iprocto_faces,imsg_type
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- 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
-
-! this is 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
-
- character(len=150) filename,prname
-
-! computed in read_compute_parameters
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
- integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
-
-! ************** PROGRAM STARTS HERE **************
-
- print *
- print *,'Check all MPI buffers between chunk faces'
- print *
-
-! read the parameter file and compute additional parameters
- call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
- print *
- print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
- print *,'There are ',NCHUNKS,' chunks'
- print *,'There are ',NPROC_XI,' slices along xi in each chunk'
- print *,'There are ',NPROC_ETA,' slices along eta in each chunk'
- print *
-
-! number of corners and faces shared between chunks and number of message types
- if(NCHUNKS == 1 .or. NCHUNKS == 2) then
- NUM_FACES = 1
- NUM_MSG_TYPES = 1
- else if(NCHUNKS == 3) then
- NUM_FACES = 1
- NUM_MSG_TYPES = 3
- else if(NCHUNKS == 6) then
- NUM_FACES = 4
- NUM_MSG_TYPES = 3
- else
- stop '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
-
- if(NCHUNKS == 1) stop 'only one chunk, nothing to check'
-
- print *,'There are ',NUMMSGS_FACES,' messages to assemble all the faces'
- print *
-
-! allocate array for messages for faces
- allocate(iprocfrom_faces(NUMMSGS_FACES))
- allocate(iprocto_faces(NUMMSGS_FACES))
- allocate(imsg_type(NUMMSGS_FACES))
-
-! 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
- 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) &
- stop 'incorrect chunk faces numbering'
- if (imsg_type(imsg) < 1 .or. imsg_type(imsg) > 3) &
- stop 'incorrect message type labeling'
- enddo
- close(IIN)
-
-! loop over all the regions of the mesh
- do iregion_code = 1,MAX_NUM_REGIONS
-
- print *
- print *,' ********* checking region ',iregion_code,' *********'
- print *
-
-! loop on all the messages between faces
- do imsg = 1,NUMMSGS_FACES
-
- print *
- print *,'Checking message ',imsg,' out of ',NUMMSGS_FACES
-
-! read 2-D buffer for the sender and the receiver
- write(filename,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
- iproc = iprocfrom_faces(imsg)
- call create_serial_name_database(prname,iproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
- open(unit=34,file=prname(1:len_trim(prname))//filename,status='old',action='read')
-
- write(filename,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
- iproc = iprocto_faces(imsg)
- call create_serial_name_database(prname,iproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
- open(unit=35,file=prname(1:len_trim(prname))//filename,status='old',action='read')
-
- write(*,*) 'reading MPI 2D buffer for sender'
- read(34,*) npoin2D_sender
- read(35,*) npoin2D_receiver
-
-! check that number of points is the same in both buffers
- if(npoin2D_sender /= npoin2D_receiver) &
- stop 'different number of points in the two buffers'
-
- print *,'this message contains ',npoin2D_sender,' points'
-
-! check all the points based upon their coordinates
- do ipoin2D = 1,npoin2D_sender
- read(34,*) iboolsend,xsend,ysend,zsend
- read(35,*) iboolreceive,xreceive,yreceive,zreceive
-
- diff = dmax1(dabs(xsend-xreceive),dabs(ysend-yreceive),dabs(zsend-zreceive))
- if(diff > 0.0000001d0) then
- print *,'different : ',ipoin2D,iboolsend,iboolreceive,diff
- print *,'xsend,xreceive = ',xsend,xreceive
- print *,'ysend,yreceive = ',ysend,yreceive
- print *,'zsend,zreceive = ',zsend,zreceive
- stop 'error: different'
- endif
-
- enddo
-
- enddo
-
- enddo
-
- print *
- print *,'done'
- print *
-
- end program check_buffers_faces_chunks
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/check_simulation_stability.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/check_simulation_stability.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/check_simulation_stability.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,346 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
- b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
- myrank) !COMPUTE_AND_STORE_STRAIN,myrank)
-
- implicit none
-
- include 'mpif.h'
- include "constants.h"
- include "precision.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- ! time step
- integer it,NSTEP,myrank
-
- ! displacement
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: displ_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: b_displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_displ_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: b_displ_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
- eps_trace_over_3_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_crust_mantle
-
- integer SIMULATION_TYPE
- character(len=150) OUTPUT_FILES
-
- double precision :: time_start,DT,t0
-
-! logical COMPUTE_AND_STORE_STRAIN
-
- ! local parameters
- ! maximum of the norm of the displacement and of the potential in the fluid
- real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all,Ufluidnorm,Ufluidnorm_all
- real(kind=CUSTOM_REAL) Strain_norm,Strain_norm_all,strain2_norm,strain2_norm_all
- real(kind=CUSTOM_REAL) b_Usolidnorm,b_Usolidnorm_all,b_Ufluidnorm,b_Ufluidnorm_all
- ! names of the data files for all the processors in MPI
- character(len=150) outputname
- ! timer MPI
- double precision :: tCPU,t_remain,t_total
- integer :: ihours,iminutes,iseconds,int_tCPU, &
- ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
- ihours_total,iminutes_total,iseconds_total,int_t_total
- ! to determine date and time at which the run will finish
- character(len=8) datein
- character(len=10) timein
- character(len=5) :: zone
- integer, dimension(8) :: time_values
- character(len=3), dimension(12) :: month_name
- character(len=3), dimension(0:6) :: weekday_name
- data month_name /'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/
- data weekday_name /'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'/
- integer :: year,mon,day,hr,minutes,timestamp,julian_day_number,day_of_week, &
- timestamp_remote,year_remote,mon_remote,day_remote,hr_remote,minutes_remote,day_of_week_remote
- integer :: ier
- integer, external :: idaywk
-
- double precision,parameter :: scale_displ = R_EARTH
-
-
- ! 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 (SIMULATION_TYPE == 3) then
- b_Usolidnorm = max( &
- maxval(sqrt(b_displ_crust_mantle(1,:)**2 + &
- b_displ_crust_mantle(2,:)**2 + b_displ_crust_mantle(3,:)**2)), &
- maxval(sqrt(b_displ_inner_core(1,:)**2 &
- + b_displ_inner_core(2,:)**2 &
- + b_displ_inner_core(3,:)**2)))
-
- b_Ufluidnorm = maxval(abs(b_displ_outer_core))
-
- ! compute the maximum of the maxima for all the slices using an MPI reduction
- call MPI_REDUCE(b_Usolidnorm,b_Usolidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
- MPI_COMM_WORLD,ier)
- call MPI_REDUCE(b_Ufluidnorm,b_Ufluidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
- MPI_COMM_WORLD,ier)
- endif
-
- if (COMPUTE_AND_STORE_STRAIN) then
- Strain_norm = maxval(abs(eps_trace_over_3_crust_mantle))
- strain2_norm= maxval(abs(epsilondev_crust_mantle))
- call MPI_REDUCE(Strain_norm,Strain_norm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
- MPI_COMM_WORLD,ier)
- call MPI_REDUCE(Strain2_norm,Strain2_norm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
- MPI_COMM_WORLD,ier)
- endif
-
- if(myrank == 0) then
-
- write(IMAIN,*) 'Time step # ',it
- 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
-
- if (SIMULATION_TYPE == 3) then
- b_Usolidnorm_all = b_Usolidnorm_all * sngl(scale_displ)
- write(IMAIN,*) 'Max norm displacement vector U in solid in all slices for back prop.(m) = ',b_Usolidnorm_all
- write(IMAIN,*) 'Max non-dimensional potential Ufluid in fluid in all slices for back prop.= ',b_Ufluidnorm_all
- endif
-
- if(COMPUTE_AND_STORE_STRAIN) then
- write(IMAIN,*) 'Max of strain, eps_trace_over_3_crust_mantle =',Strain_norm_all
- write(IMAIN,*) 'Max of strain, epsilondev_crust_mantle =',Strain2_norm_all
- endif
-
- ! 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 < NSTEP) then
-
- ! get current date
- call date_and_time(datein,timein,zone,time_values)
- ! time_values(1): year
- ! time_values(2): month of the year
- ! time_values(3): day of the month
- ! time_values(5): hour of the day
- ! time_values(6): minutes of the hour
-
- ! compute date at which the run should finish; for simplicity only minutes
- ! are considered, seconds are ignored; in any case the prediction is not
- ! accurate down to seconds because of system and network fluctuations
- year = time_values(1)
- mon = time_values(2)
- day = time_values(3)
- hr = time_values(5)
- minutes = time_values(6)
-
- ! get timestamp in minutes of current date and time
- call convtime(timestamp,year,mon,day,hr,minutes)
-
- ! add remaining minutes
- timestamp = timestamp + nint(t_remain / 60.d0)
-
- ! get date and time of that future timestamp in minutes
- call invtime(timestamp,year,mon,day,hr,minutes)
-
- ! convert to Julian day to get day of the week
- call calndr(day,mon,year,julian_day_number)
- day_of_week = idaywk(julian_day_number)
-
- write(IMAIN,"(' The run will finish approximately on (in local time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
- weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
-
- ! print date and time estimate of end of run in another country.
- ! For instance: the code runs at Caltech in California but the person
- ! running the code is connected remotely from France, which has 9 hours more
- if(ADD_TIME_ESTIMATE_ELSEWHERE .and. HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE /= 0) then
-
- ! add time difference with that remote location (can be negative)
- timestamp_remote = timestamp + HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE
-
- ! get date and time of that future timestamp in minutes
- call invtime(timestamp_remote,year_remote,mon_remote,day_remote,hr_remote,minutes_remote)
-
- ! convert to Julian day to get day of the week
- call calndr(day_remote,mon_remote,year_remote,julian_day_number)
- day_of_week_remote = idaywk(julian_day_number)
-
- if(HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE > 0) then
- write(IMAIN,*) 'Adding positive time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
- else
- write(IMAIN,*) 'Adding negative time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
- endif
- write(IMAIN,*) 'and ',abs(MINUTES_TIME_DIFFERENCE),' minutes to get estimate at a remote location'
- write(IMAIN, &
- "(' The run will finish approximately on: ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
- weekday_name(day_of_week_remote),month_name(mon_remote),day_remote,year_remote,hr_remote,minutes_remote
- endif
-
- if(it < 100) then
- write(IMAIN,*) '************************************************************'
- write(IMAIN,*) '**** BEWARE: the above time estimates are not reliable'
- write(IMAIN,*) '**** because fewer than 100 iterations have been performed'
- write(IMAIN,*) '************************************************************'
- endif
-
- endif
-
- write(IMAIN,*)
-
- ! write time stamp file to give information about progression of simulation
- write(outputname,"('/timestamp',i6.6)") it
-
- open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',action='write')
-
- write(IOUT,*) 'Time step # ',it
- write(IOUT,*) 'Time: ',sngl(((it-1)*DT-t0)/60.d0),' minutes'
- write(IOUT,*)
- write(IOUT,*) 'Max norm displacement vector U in solid in all slices (m) = ',Usolidnorm_all
- write(IOUT,*) 'Max non-dimensional potential Ufluid in fluid in all slices = ',Ufluidnorm_all
- write(IOUT,*)
-
- if (SIMULATION_TYPE == 3) then
- write(IOUT,*) 'Max norm displacement vector U in solid in all slices for back prop.(m) = ',b_Usolidnorm_all
- write(IOUT,*) 'Max non-dimensional potential Ufluid in fluid in all slices for back prop.= ',b_Ufluidnorm_all
- write(IOUT,*)
- endif
-
- write(IOUT,*) 'Elapsed time in seconds = ',tCPU
- write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
- write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
- write(IOUT,*)
-
- write(IOUT,*) 'Time steps done = ',it,' out of ',NSTEP
- write(IOUT,*) 'Time steps remaining = ',NSTEP - it
- write(IOUT,*) 'Estimated remaining time in seconds = ',t_remain
- write(IOUT,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- ihours_remain,iminutes_remain,iseconds_remain
- write(IOUT,*)
-
- write(IOUT,*) 'Estimated total run time in seconds = ',t_total
- write(IOUT,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- ihours_total,iminutes_total,iseconds_total
- write(IOUT,*) 'We have done ',sngl(100.d0*dble(it)/dble(NSTEP)),'% of that'
- write(IOUT,*)
-
- if(it < NSTEP) then
-
- write(IOUT,"(' The run will finish approximately on (in local time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
- weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
-
- ! print date and time estimate of end of run in another country.
- ! For instance: the code runs at Caltech in California but the person
- ! running the code is connected remotely from France, which has 9 hours more
- if(ADD_TIME_ESTIMATE_ELSEWHERE .and. HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE /= 0) then
- if(HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE > 0) then
- write(IOUT,*) 'Adding positive time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
- else
- write(IOUT,*) 'Adding negative time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
- endif
- write(IOUT,*) 'and ',abs(MINUTES_TIME_DIFFERENCE),' minutes to get estimate at a remote location'
- write(IOUT, &
- "(' The run will finish approximately on (in remote time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
- weekday_name(day_of_week_remote),month_name(mon_remote), &
- day_remote,year_remote,hr_remote,minutes_remote
- endif
-
- if(it < 100) then
- write(IOUT,*)
- write(IOUT,*) '************************************************************'
- write(IOUT,*) '**** BEWARE: the above time estimates are not reliable'
- write(IOUT,*) '**** because fewer than 100 iterations have been performed'
- write(IOUT,*) '************************************************************'
- endif
-
- endif
-
- close(IOUT)
-
- ! check stability of the code, exit if unstable
- ! negative values can occur with some compilers when the unstable value is greater
- ! than the greatest possible floating-point number of the machine
- if(Usolidnorm_all > STABILITY_THRESHOLD .or. Usolidnorm_all < 0) &
- call exit_MPI(myrank,'forward simulation became unstable and blew up in the solid')
- if(Ufluidnorm_all > STABILITY_THRESHOLD .or. Ufluidnorm_all < 0) &
- call exit_MPI(myrank,'forward simulation became unstable and blew up in the fluid')
-
- if(SIMULATION_TYPE == 3) then
- if(b_Usolidnorm_all > STABILITY_THRESHOLD .or. b_Usolidnorm_all < 0) &
- call exit_MPI(myrank,'backward simulation became unstable and blew up in the solid')
- if(b_Ufluidnorm_all > STABILITY_THRESHOLD .or. b_Ufluidnorm_all < 0) &
- call exit_MPI(myrank,'backward simulation became unstable and blew up in the fluid')
- endif
-
- endif
-
- end subroutine check_simulation_stability
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/combine_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/combine_AVS_DX.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/combine_AVS_DX.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1214 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! combine AVS or DX global data files to check the mesh
-! this is done in postprocessing after running the mesh generator
-
- program combine_AVS_DX
-
- implicit none
-
- include "constants.h"
-
-! threshold for number of points per wavelength displayed
-! otherwise the scale is too large and we cannot see the small values
-! all values above this threshold are truncated
- double precision, parameter :: THRESHOLD_GRIDPOINTS = 12.
-
-! non-linear scaling factor for elevation if topography for Earth model
- double precision, parameter :: SCALE_NON_LINEAR = 0.3
-
-! maximum polynomial degree for which we can compute the stability condition
- integer, parameter :: NGLL_MAX_STABILITY = 15
-
- integer iproc,nspec,npoin
- integer ispec
- integer iglob1,iglob2,iglob3,iglob4
- integer ipoin,numpoin,numpoin2,iglobpointoffset,ntotpoin,ntotspec
- integer numelem,numelem2,iglobelemoffset,idoubling,maxdoubling
- integer iformat,ivalue,icolor,itarget_doubling
- integer imaterial,imatprop,ispec_scale_AVS_DX
- integer nrec,ir,iregion_code
- integer ntotpoinAVS_DX,ntotspecAVS_DX
-
- real(kind=CUSTOM_REAL) vmin,vmax,deltavp,deltavs
- double precision xval,yval,zval
- double precision val_color,rnorm_factor
-
- logical threshold_used
- logical USE_OPENDX
-
-! for source location
- integer yr,jda,ho,mi
- double precision x_target_source,y_target_source,z_target_source
- double precision r_target_source
- double precision x_source_trgl1,y_source_trgl1,z_source_trgl1
- double precision x_source_trgl2,y_source_trgl2,z_source_trgl2
- double precision x_source_trgl3,y_source_trgl3,z_source_trgl3
- double precision theta,phi,delta_trgl
- double precision sec,min_tshift_cmt_original !,tshift_cmt,hdur
- !double precision lat,long,depth
- double precision, dimension(1) :: tshift_cmt,hdur,lat,long,depth
-
- double precision moment_tensor(6)
-
-! for receiver location
- integer irec,ios
- double precision r_target
- double precision, allocatable, dimension(:) :: stlat,stlon,stele,stbur
- character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
- character(len=150) dummystring
-
- double precision, allocatable, dimension(:) :: x_target,y_target,z_target
-
-! for the reference ellipsoid
- double precision reference,radius_dummy,theta_s,phi_s
-
-! processor identification
- character(len=150) prname
-
-! small offset for source and receiver line in AVS_DX
-! (small compared to normalized radius of the Earth)
-
-! for full Earth
- double precision, parameter :: small_offset_source_earth = 0.025d0
- double precision, parameter :: small_offset_receiver_earth = 0.0125d0
-
-! for oceans only
- logical OCEANS_ONLY
- integer ioceans
- integer above_zero,below_zero
-
-! for stability condition
- double precision, dimension (:), allocatable :: stability_value,gridpoints_per_wavelength,elevation_sphere
- double precision, dimension (:), allocatable :: dvp,dvs
- double precision, dimension (:), allocatable :: xcoord,ycoord,zcoord,vmincoord,vmaxcoord
- double precision stability_value_min,stability_value_max
- double precision gridpoints_per_wavelength_min,gridpoints_per_wavelength_max
- integer iloop_corners,istab,jstab
- integer ipointnumber1_horiz,ipointnumber2_horiz
- integer ipointnumber1_vert,ipointnumber2_vert
- double precision distance_horiz,distance_vert
- double precision stabmax,gridmin,scale_factor
- integer NGLL_current_horiz,NGLL_current_vert
- double precision :: percent_GLL(NGLL_MAX_STABILITY)
-
-! for chunk numbering
- integer iproc_read,ichunk,idummy1,idummy2
- integer, dimension(:), allocatable :: ichunk_slice
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- RMOHO_FICTITIOUS_IN_MESHER
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- 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
-
-! for all the regions
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC_COMP, &
- 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 region_min,region_max
-
- double precision small_offset_source,small_offset_receiver
-
- integer proc_p1,proc_p2
-
-! computed in read_compute_parameters
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
- integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
-
-! ************** PROGRAM STARTS HERE **************
-
- print *
- print *,'Recombining all AVS or DX files for slices'
- print *
-
- print *
- print *,'reading parameter file'
- print *
-
-! read the parameter file and compute additional parameters
- call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,&
- MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC_COMP,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX,&
- NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,&
- this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,&
- HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,&
- USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
-
- if(.not. SAVE_MESH_FILES) stop 'AVS or DX files were not saved by the mesher'
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
- print *,'1 = create files in OpenDX format'
- print *,'2 = create files in AVS UCD format'
- print *,'any other value = exit'
- print *
- print *,'enter value:'
- read(5,*) iformat
- if(iformat<1 .or. iformat>2) stop 'exiting...'
- if(iformat == 1) then
- USE_OPENDX = .true.
- else
- USE_OPENDX = .false.
- endif
-
- print *
- print *,'1 = edges of all the slices only'
- print *,'2 = edges of the chunks only'
- print *,'3 = surface of the model only'
- print *,'any other value = exit'
- print *
- print *,'enter value:'
- read(5,*) ivalue
- if(ivalue<1 .or. ivalue>3) stop 'exiting...'
-
-! warning if surface elevation
- if(ivalue == 3) then
- print *,'******************************************'
- print *,'*** option 7 to color using topography ***'
- print *,'******************************************'
- endif
-
- print *
- print *,'1 = color by doubling flag'
- print *,'2 = by slice number'
- print *,'3 = by stability value'
- print *,'4 = by gridpoints per wavelength'
- print *,'5 = dvp/vp'
- print *,'6 = dvs/vs'
- print *,'7 = elevation of Earth model'
- print *,'8 = by region number'
- print *,'9 = focus on one doubling flag only'
- print *,'any other value=exit'
- print *
- print *,'enter value:'
- read(5,*) icolor
- if(icolor<1 .or. icolor >9) stop 'exiting...'
- if((icolor == 3 .or. icolor == 4) .and. ivalue /= 2) &
- stop 'need chunks only to represent stability or gridpoints per wavelength'
-
- if(icolor == 9) then
- print *
- print *,'enter value of target doubling flag:'
- read(5,*) itarget_doubling
- endif
-
-! for oceans only
- OCEANS_ONLY = .false.
- if(ivalue == 3 .and. icolor == 7) then
- print *
- print *,'1 = represent full topography (topo + oceans)'
- print *,'2 = represent oceans only'
- print *
- read(5,*) ioceans
- if(ioceans == 1) then
- OCEANS_ONLY = .false.
- else if(ioceans == 2) then
- OCEANS_ONLY = .true.
- else
- stop 'incorrect option for the oceans'
- endif
- endif
-
- print *
- print *,'1 = material property by doubling flag'
- print *,'2 = by slice number'
- print *,'3 = by region number'
- print *,'4 = by chunk number'
- print *,'any other value=exit'
- print *
- print *,'enter value:'
- read(5,*) imaterial
- if(imaterial < 1 .or. imaterial > 4) stop 'exiting...'
-
-! user can specify a range of processors here
- print *
- print *,'enter first proc (proc numbers start at 0) = '
- read(5,*) proc_p1
- if(proc_p1 < 0) proc_p1 = 0
- if(proc_p1 > NPROCTOT-1) proc_p1 = NPROCTOT-1
-
- print *,'enter last proc (enter -1 for all procs) = '
- read(5,*) proc_p2
- if(proc_p2 == -1) proc_p2 = NPROCTOT-1
- if(proc_p2 < 0) proc_p2 = 0
- if(proc_p2 > NPROCTOT-1) proc_p2 = NPROCTOT-1
-
-! set interval to maximum if user input is not correct
- if(proc_p1 <= 0) proc_p1 = 0
- if(proc_p2 < 0) proc_p2 = NPROCTOT - 1
-
- print *
- print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
- print *
-
-! open file with global slice number addressing
- write(*,*) 'reading slice addressing'
- write(*,*)
- allocate(ichunk_slice(0:NPROCTOT-1))
-
- open(unit=IIN,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read')
- do iproc = 0,NPROCTOT-1
- read(IIN,*) iproc_read,ichunk,idummy1,idummy2
- if(iproc_read /= iproc) stop 'incorrect slice number read'
- ichunk_slice(iproc) = ichunk
- enddo
- close(IIN)
-
-! define percentage of smallest distance between GLL points for NGLL points
-! percentages were computed by calling the GLL points routine for each degree
- percent_GLL(2) = 100.d0
- percent_GLL(3) = 50.d0
- percent_GLL(4) = 27.639320225002102d0
- percent_GLL(5) = 17.267316464601141d0
- percent_GLL(6) = 11.747233803526763d0
- percent_GLL(7) = 8.4888051860716516d0
- percent_GLL(8) = 6.4129925745196719d0
- percent_GLL(9) = 5.0121002294269914d0
- percent_GLL(10) = 4.0233045916770571d0
- percent_GLL(11) = 3.2999284795970416d0
- percent_GLL(12) = 2.7550363888558858d0
- percent_GLL(13) = 2.3345076678918053d0
- percent_GLL(14) = 2.0032477366369594d0
- percent_GLL(15) = 1.7377036748080721d0
-
-! convert to real percentage
- percent_GLL(:) = percent_GLL(:) / 100.d0
-
-! clear flag to detect if threshold used
- threshold_used = .false.
-
-! set length of segments for source and receiver representation
- small_offset_source = small_offset_source_earth
- small_offset_receiver = small_offset_receiver_earth
-
-! set total number of points and elements to zero
- ntotpoin = 0
- ntotspec = 0
-
- region_min = 1
- region_max = MAX_NUM_REGIONS
-
-! if representing surface elements, only one region
- if(ivalue == 3) then
- region_min = IREGION_CRUST_MANTLE
- region_max = IREGION_CRUST_MANTLE
- endif
-
- do iregion_code = region_min,region_max
-
-! loop on the selected range of processors
- do iproc = proc_p1,proc_p2
-
- print *,'Reading slice ',iproc,' in region ',iregion_code
-
-! create the name for the database of the current slide
- call create_serial_name_database(prname,iproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
-
- if(ivalue == 1) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read')
- else if(ivalue == 2) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='old',action='read')
- else if(ivalue == 3) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
- endif
-
- read(10,*) npoin
- print *,'There are ',npoin,' global AVS or DX points in the slice'
- ntotpoin = ntotpoin + npoin
- close(10)
-
- if(ivalue == 1) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read')
- else if(ivalue == 2) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='old',action='read')
- else if(ivalue == 3) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read')
- endif
-
- read(10,*) nspec
- print *,'There are ',nspec,' AVS or DX elements in the slice'
- ntotspec = ntotspec + nspec
- close(10)
-
- enddo
- enddo
-
- print *
- print *,'There is a total of ',ntotspec,' elements in all the slices'
- print *,'There is a total of ',ntotpoin,' points in all the slices'
- print *
-
- ntotpoinAVS_DX = ntotpoin
- ntotspecAVS_DX = ntotspec
-
-! write AVS or DX header with element data
- if(USE_OPENDX) then
- open(unit=11,file=trim(OUTPUT_FILES)//'/DX_fullmesh.dx',status='unknown')
- write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ntotpoinAVS_DX,' data follows'
- else
- open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_fullmesh.inp',status='unknown')
- write(11,*) ntotpoinAVS_DX,' ',ntotspecAVS_DX,' 0 1 0'
- endif
-
-! allocate array for stability condition
- allocate(stability_value(ntotspecAVS_DX))
- allocate(gridpoints_per_wavelength(ntotspecAVS_DX))
- allocate(elevation_sphere(ntotspecAVS_DX))
- allocate(dvp(ntotspecAVS_DX))
- allocate(dvs(ntotspecAVS_DX))
- allocate(xcoord(ntotpoinAVS_DX))
- allocate(ycoord(ntotpoinAVS_DX))
- allocate(zcoord(ntotpoinAVS_DX))
- allocate(vmincoord(ntotpoinAVS_DX))
- allocate(vmaxcoord(ntotpoinAVS_DX))
-
-! ************* generate points ******************
-
-! set global point offset to zero
- iglobpointoffset = 0
-
- do iregion_code = region_min,region_max
-
-! loop on the selected range of processors
- do iproc=proc_p1,proc_p2
-
- print *,'Reading slice ',iproc,' in region ',iregion_code
-
-! create the name for the database of the current slide
- call create_serial_name_database(prname,iproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
-
- if(ivalue == 1) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read')
- else if(ivalue == 2) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='old',action='read')
- open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointschunks_stability.txt',status='old',action='read')
- else if(ivalue == 3) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
- endif
-
- read(10,*) npoin
- print *,'There are ',npoin,' global AVS or DX points in the slice'
-
-! read local points in this slice and output global AVS or DX points
- do ipoin=1,npoin
- read(10,*) numpoin,xval,yval,zval
- if(ivalue == 2) then
- read(12,*) numpoin2,vmin,vmax
- else
- numpoin2 = 0
- vmin = 0.
- vmax = 0.
- endif
- if(numpoin /= ipoin) stop 'incorrect point number'
- if(ivalue == 2 .and. numpoin2 /= ipoin) stop 'incorrect point number'
-! write to AVS or DX global file with correct offset
- if(USE_OPENDX) then
- write(11,"(f10.7,1x,f10.7,1x,f10.7)") xval,yval,zval
- else
- write(11,"(i6,1x,f10.7,1x,f10.7,1x,f10.7)") numpoin + iglobpointoffset,xval,yval,zval
- endif
-
-! save coordinates in global array of points for stability condition
- xcoord(numpoin + iglobpointoffset) = xval
- ycoord(numpoin + iglobpointoffset) = yval
- zcoord(numpoin + iglobpointoffset) = zval
- vmincoord(numpoin + iglobpointoffset) = vmin
- vmaxcoord(numpoin + iglobpointoffset) = vmax
-
- enddo
-
- iglobpointoffset = iglobpointoffset + npoin
-
- close(10)
- if(ivalue == 2) close(12)
-
- enddo
- enddo
-
-! ************* generate elements ******************
-
-! get source information for frequency for number of points per lambda
- print *,'reading source duration from the CMTSOLUTION file'
- call get_cmt(yr,jda,ho,mi,sec,tshift_cmt,hdur,lat,long,depth,moment_tensor, &
- DT,1,min_tshift_cmt_original)
-
-! set global element and point offsets to zero
- iglobpointoffset = 0
- iglobelemoffset = 0
- maxdoubling = -1
- above_zero = 0
- below_zero = 0
-
- if(USE_OPENDX) write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows'
-
- do iregion_code = region_min,region_max
-
-! loop on the selected range of processors
- do iproc=proc_p1,proc_p2
-
- print *,'Reading slice ',iproc,' in region ',iregion_code
-
-! create the name for the database of the current slide
- call create_serial_name_database(prname,iproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
-
- if(ivalue == 1) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read')
- open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read')
- if(icolor == 5 .or. icolor == 6) &
- open(unit=13,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces_dvp_dvs.txt',status='old',action='read')
- else if(ivalue == 2) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='old',action='read')
- if(icolor == 5 .or. icolor == 6) &
- open(unit=13,file=prname(1:len_trim(prname))//'AVS_DXelementschunks_dvp_dvs.txt',status='old',action='read')
- open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='old',action='read')
- else if(ivalue == 3) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read')
- open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
- if(icolor == 5 .or. icolor == 6) &
- open(unit=13,file=prname(1:len_trim(prname))//'AVS_DXelementssurface_dvp_dvs.txt',status='old',action='read')
-
- endif
-
- read(10,*) nspec
- read(12,*) npoin
- print *,'There are ',npoin,' global AVS or DX points in the slice'
- print *,'There are ',nspec,' AVS or DX elements in the slice'
-
-! read local elements in this slice and output global AVS or DX elements
- do ispec=1,nspec
- read(10,*) numelem,idoubling,iglob1,iglob2,iglob3,iglob4
- if(icolor == 5 .or. icolor == 6) then
- read(13,*) numelem2,deltavp,deltavs
- dvp(numelem + iglobelemoffset) = deltavp
- dvs(numelem + iglobelemoffset) = deltavs
- else
- numelem2 = 0
- endif
- if(numelem /= ispec) stop 'incorrect element number'
- if((icolor == 5 .or. icolor == 6) .and. numelem2 /= ispec) stop 'incorrect element number'
-! compute max of the doubling flag
- maxdoubling = max(maxdoubling,idoubling)
-
-! assign material property (which can be filtered later in AVS_DX)
- if(imaterial == 1) then
- imatprop = idoubling
- else if(imaterial == 2) then
- imatprop = iproc
- else if(imaterial == 3) then
- imatprop = iregion_code
- else if(imaterial == 4) then
- imatprop = ichunk_slice(iproc)
- else
- stop 'invalid code for material property'
- endif
-
-! write to AVS or DX global file with correct offset
-
-! quadrangles (2-D)
- iglob1 = iglob1 + iglobpointoffset
- iglob2 = iglob2 + iglobpointoffset
- iglob3 = iglob3 + iglobpointoffset
- iglob4 = iglob4 + iglobpointoffset
-
-! in the case of OpenDX, node numbers start at zero
-! in the case of AVS, node numbers start at one
- if(USE_OPENDX) then
-! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
- write(11,"(i6,1x,i6,1x,i6,1x,i6)") iglob1-1,iglob4-1,iglob2-1,iglob3-1
- else
- write(11,"(i6,1x,i3,' quad ',i6,1x,i6,1x,i6,1x,i6)") numelem + iglobelemoffset,imatprop,iglob1,iglob2,iglob3,iglob4
- endif
-
-! get number of GLL points in current element
- NGLL_current_horiz = NGLLX
- NGLL_current_vert = NGLLZ
-
-! check that the degree is not above the threshold for list of percentages
- if(NGLL_current_horiz > NGLL_MAX_STABILITY .or. &
- NGLL_current_vert > NGLL_MAX_STABILITY) &
- stop 'degree too high to compute stability value'
-
-! scaling factor to compute real value of stability condition
- scale_factor = dsqrt(PI*GRAV*RHOAV)
-
-! compute stability value
- stabmax = -1.d0
- gridmin = HUGEVAL
-
- if(idoubling == IFLAG_CRUST) then
-
-! distinguish between horizontal and vertical directions in crust
-! because we have a different polynomial degree in each direction
-! this works because the mesher always creates the 2D surfaces starting
-! from the lower-left corner, continuing to the lower-right corner and so on
- do iloop_corners = 1,2
-
- select case(iloop_corners)
-
- case(1)
- ipointnumber1_horiz = iglob1
- ipointnumber2_horiz = iglob2
-
- ipointnumber1_vert = iglob1
- ipointnumber2_vert = iglob4
-
- case(2)
- ipointnumber1_horiz = iglob4
- ipointnumber2_horiz = iglob3
-
- ipointnumber1_vert = iglob2
- ipointnumber2_vert = iglob3
-
- end select
-
- distance_horiz = &
- dsqrt((xcoord(ipointnumber2_horiz)-xcoord(ipointnumber1_horiz))**2 &
- + (ycoord(ipointnumber2_horiz)-ycoord(ipointnumber1_horiz))**2 &
- + (zcoord(ipointnumber2_horiz)-zcoord(ipointnumber1_horiz))**2)
-
- distance_vert = &
- dsqrt((xcoord(ipointnumber2_vert)-xcoord(ipointnumber1_vert))**2 &
- + (ycoord(ipointnumber2_vert)-ycoord(ipointnumber1_vert))**2 &
- + (zcoord(ipointnumber2_vert)-zcoord(ipointnumber1_vert))**2)
-
-! compute stability value using the scaled interval
- stabmax = dmax1(scale_factor*DT*vmaxcoord(ipointnumber1_horiz)/(distance_horiz*percent_GLL(NGLL_current_horiz)),stabmax)
- stabmax = dmax1(scale_factor*DT*vmaxcoord(ipointnumber1_vert)/(distance_vert*percent_GLL(NGLL_current_vert)),stabmax)
-
-! compute number of points per wavelength
- gridmin = dmin1(scale_factor*hdur(1)*vmincoord(ipointnumber1_horiz)*dble(NGLL_current_horiz)/distance_horiz,gridmin)
- gridmin = dmin1(scale_factor*hdur(1)*vmincoord(ipointnumber1_vert)*dble(NGLL_current_vert)/distance_vert,gridmin)
-
- enddo
-
-! regular regions with same polynomial degree everywhere
-
- else
-
- do istab = 1,4
- do jstab = 1,4
- if(jstab /= istab) then
-
- if(istab == 1) then
- ipointnumber1_vert = iglob1
- else if(istab == 2) then
- ipointnumber1_vert = iglob2
- else if(istab == 3) then
- ipointnumber1_vert = iglob3
- else if(istab == 4) then
- ipointnumber1_vert = iglob4
- endif
-
- if(jstab == 1) then
- ipointnumber2_vert = iglob1
- else if(jstab == 2) then
- ipointnumber2_vert = iglob2
- else if(jstab == 3) then
- ipointnumber2_vert = iglob3
- else if(jstab == 4) then
- ipointnumber2_vert = iglob4
- endif
-
- distance_vert = &
- dsqrt((xcoord(ipointnumber2_vert)-xcoord(ipointnumber1_vert))**2 &
- + (ycoord(ipointnumber2_vert)-ycoord(ipointnumber1_vert))**2 &
- + (zcoord(ipointnumber2_vert)-zcoord(ipointnumber1_vert))**2)
-
-! compute stability value using the scaled interval
- stabmax = dmax1(scale_factor*DT*vmaxcoord(ipointnumber1_vert)/(distance_vert*percent_GLL(NGLL_current_vert)),stabmax)
-
-! compute number of points per wavelength
- gridmin = dmin1(scale_factor*hdur(1)*vmincoord(ipointnumber1_vert)*dble(NGLL_current_vert)/distance_vert,gridmin)
-
- endif
- enddo
- enddo
-
- endif
-
- stability_value(numelem + iglobelemoffset) = stabmax
- gridpoints_per_wavelength(numelem + iglobelemoffset) = gridmin
-
-! compute elevation to represent ellipticity or topography at the surface
-! use point iglob1 for instance and subtract reference
-
-! get colatitude and longitude of current point
- xval = xcoord(iglob1)
- yval = ycoord(iglob1)
- zval = zcoord(iglob1)
-
- call xyz_2_rthetaphi_dble(xval,yval,zval,radius_dummy,theta_s,phi_s)
- call reduce(theta_s,phi_s)
-
-! if topography then subtract reference ellipsoid or sphere for color code
-! if ellipticity then subtract reference sphere for color code
-! otherwise subtract nothing
- if(TOPOGRAPHY .or. CRUSTAL) then
- if(ELLIPTICITY) then
- reference = 1.d0 - (3.d0*dcos(theta_s)**2 - 1.d0)/3.d0/299.8d0
- else
- reference = R_UNIT_SPHERE
- endif
- else if(ELLIPTICITY) then
- reference = R_UNIT_SPHERE
- else
- reference = 0.
- endif
-
-! compute elevation
- elevation_sphere(numelem + iglobelemoffset) = &
- (dsqrt(xval**2 + yval**2 + zval**2) - reference)
-
- enddo
-
- iglobelemoffset = iglobelemoffset + nspec
- iglobpointoffset = iglobpointoffset + npoin
-
- close(10)
- close(12)
- if(icolor == 5 .or. icolor == 6) close(13)
-
- enddo
- enddo
-
-! saturate color scale for elevation since small values
-! apply non linear scaling if topography to enhance regions around sea level
-
- if(TOPOGRAPHY .or. CRUSTAL) then
-
-! compute absolute maximum
- rnorm_factor = maxval(dabs(elevation_sphere(:)))
-
-! map to [-1,1]
- elevation_sphere(:) = elevation_sphere(:) / rnorm_factor
-
-! apply non-linear scaling
- do ispec_scale_AVS_DX = 1,ntotspecAVS_DX
-
- xval = elevation_sphere(ispec_scale_AVS_DX)
-
-! compute total area consisting of oceans
-! and suppress areas that are not considered oceans if needed
-! use arbitrary threshold to suppress artefacts in ETOPO5 model
- if(xval >= -0.018) then
- if(OCEANS_ONLY) xval = 0.
- above_zero = above_zero + 1
- else
- below_zero = below_zero + 1
- endif
-
- if(xval >= 0.) then
- if(.not. OCEANS_ONLY) then
- elevation_sphere(ispec_scale_AVS_DX) = xval ** SCALE_NON_LINEAR
- else
- elevation_sphere(ispec_scale_AVS_DX) = 0.
- endif
- else
- elevation_sphere(ispec_scale_AVS_DX) = - dabs(xval) ** SCALE_NON_LINEAR
- endif
-
- enddo
-
- else
-
-! regular scaling to real distance if no topography
- elevation_sphere(:) = R_EARTH * elevation_sphere(:)
-
- endif
-
- if(icolor == 5 .or. icolor == 6) then
-
- if(ISOTROPIC_3D_MANTLE) then
-
-! compute absolute maximum for dvp
- rnorm_factor = maxval(dabs(dvp(:)))
-
-! map to [-1,1]
- dvp(:) = dvp(:) / rnorm_factor
-
-! apply non-linear scaling
- do ispec_scale_AVS_DX = 1,ntotspecAVS_DX
- xval = dvp(ispec_scale_AVS_DX)
- if(xval >= 0.) then
- dvp(ispec_scale_AVS_DX) = xval ** SCALE_NON_LINEAR
- else
- dvp(ispec_scale_AVS_DX) = - dabs(xval) ** SCALE_NON_LINEAR
- endif
- enddo
-
-! compute absolute maximum for dvs
- rnorm_factor = maxval(dabs(dvs(:)))
-
-! map to [-1,1]
- dvs(:) = dvs(:) / rnorm_factor
-
-! apply non-linear scaling
- do ispec_scale_AVS_DX = 1,ntotspecAVS_DX
- xval = dvs(ispec_scale_AVS_DX)
- if(xval >= 0.) then
- dvs(ispec_scale_AVS_DX) = xval ** SCALE_NON_LINEAR
- else
- dvs(ispec_scale_AVS_DX) = - dabs(xval) ** SCALE_NON_LINEAR
- endif
- enddo
-
- endif
- endif
-
-! ************* generate element data values ******************
-
-! output AVS or DX header for data
- if(USE_OPENDX) then
- write(11,*) 'attribute "element type" string "quads"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
- else
- write(11,*) '1 1'
- write(11,*) 'Zcoord, meters'
- endif
-
-! set global element and point offsets to zero
- iglobelemoffset = 0
-
- do iregion_code = region_min,region_max
-
-! loop on the selected range of processors
- do iproc=proc_p1,proc_p2
-
- print *,'Reading slice ',iproc,' in region ',iregion_code
-
-! create the name for the database of the current slide
- call create_serial_name_database(prname,iproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
-
- if(ivalue == 1) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read')
- else if(ivalue == 2) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='old',action='read')
- else if(ivalue == 3) then
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read')
- endif
-
- read(10,*) nspec
- print *,'There are ',nspec,' AVS or DX elements in the slice'
-
-! read local elements in this slice and output global AVS or DX elements
- do ispec=1,nspec
- read(10,*) numelem,idoubling,iglob1,iglob2,iglob3,iglob4
- if(numelem /= ispec) stop 'incorrect element number'
-
-! data is either the slice number or the mesh doubling region flag
- if(icolor == 1) then
- val_color = dble(idoubling)
- else if(icolor == 2) then
- val_color = dble(iproc)
- else if(icolor == 3) then
- val_color = stability_value(numelem + iglobelemoffset)
- else if(icolor == 4) then
- val_color = gridpoints_per_wavelength(numelem + iglobelemoffset)
-! put a threshold for number of points per wavelength displayed
-! otherwise the scale is too large and we cannot see the small values
- if(val_color > THRESHOLD_GRIDPOINTS) then
- val_color = THRESHOLD_GRIDPOINTS
- threshold_used = .true.
- endif
- else if(icolor == 5) then
-! minus sign to get the color scheme right: blue is fast (+) and red is slow (-)
- val_color = -dvp(numelem + iglobelemoffset)
- else if(icolor == 6) then
-! minus sign to get the color scheme right: blue is fast (+) and red is slow (-)
- val_color = -dvs(numelem + iglobelemoffset)
- else if(icolor == 7) then
- val_color = elevation_sphere(numelem + iglobelemoffset)
-
- else if(icolor == 8) then
- val_color = iregion_code
- else if(icolor == 9) then
- if(idoubling == itarget_doubling) then
- val_color = dble(iregion_code)
- else
- val_color = dble(IFLAG_DUMMY)
- endif
- else
- stop 'incorrect coloring code'
- endif
-
-! write to AVS or DX global file with correct offset
- if(USE_OPENDX) then
- write(11,*) sngl(val_color)
- else
- write(11,*) numelem + iglobelemoffset,' ',sngl(val_color)
- endif
- enddo
-
- iglobelemoffset = iglobelemoffset + nspec
-
- close(10)
-
- enddo
- enddo
-
-! define OpenDX field
- if(USE_OPENDX) then
- write(11,*) 'attribute "dep" string "connections"'
- write(11,*) 'object "irregular positions irregular connections" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
- endif
-
- close(11)
-
- print *
- print *,'maximum value of doubling flag in all slices = ',maxdoubling
- print *
-
-! print min and max of stability and points per lambda
-
- if(ivalue == 2) then
-
-! compute minimum and maximum of stability value and points per wavelength
-
- stability_value_min = minval(stability_value)
- stability_value_max = maxval(stability_value)
-
- gridpoints_per_wavelength_min = minval(gridpoints_per_wavelength)
- gridpoints_per_wavelength_max = maxval(gridpoints_per_wavelength)
-
- print *
- print *,'stability value min, max, ratio = ', &
- stability_value_min,stability_value_max,stability_value_max / stability_value_min
-
- print *
- print *,'number of points per wavelength min, max, ratio = ', &
- gridpoints_per_wavelength_min,gridpoints_per_wavelength_max, &
- gridpoints_per_wavelength_max / gridpoints_per_wavelength_min
-
- print *
- print *,'half duration of ',sngl(hdur(1)),' s used for points per wavelength'
- print *
-
- if(hdur(1) < 5.*DT) then
- print *,'***************************************************************'
- print *,'Source time function is a Heaviside, points per wavelength meaningless'
- print *,'***************************************************************'
- print *
- endif
-
- if(icolor == 4 .and. threshold_used) then
- print *,'***************************************************************'
- print *,'the number of points per wavelength have been cut above a threshold'
- print *,'of ',THRESHOLD_GRIDPOINTS,' to avoid saturation of color scale'
- print *,'***************************************************************'
- print *
- endif
- endif
-
-! if we have the surface for the Earth, print min and max of elevation
-
- if(ivalue == 3) then
- print *
- print *,'elevation min, max = ',minval(elevation_sphere),maxval(elevation_sphere)
- if(TOPOGRAPHY .or. CRUSTAL) print *,'elevation has been normalized for topography'
- print *
-
-! print percentage of oceans at surface of the globe
- print *
- print *,'the oceans represent ',100. * below_zero / (above_zero + below_zero),' % of the surface of the mesh'
- print *
-
- endif
-
-!
-! create an AVS or DX file with the source and the receivers as well
-!
-
-! get source information
- print *,'reading position of the source from the CMTSOLUTION file'
- call get_cmt(yr,jda,ho,mi,sec,tshift_cmt,hdur,lat,long,depth,moment_tensor, &
- DT,1,min_tshift_cmt_original)
-
-! convert geographic latitude lat (degrees)
-! to geocentric colatitude theta (radians)
- theta=PI/2.0d0-atan(0.99329534d0*tan(dble(lat(1))*PI/180.0d0))
- phi=dble(long(1))*PI/180.0d0
- call reduce(theta,phi)
-
-! compute Cartesian position of the source (ignore ellipticity for AVS_DX)
-! the point for the source is put at the surface for clarity (depth ignored)
-! even slightly above to superimpose to real surface
- r_target_source = 1.02d0
- x_target_source = r_target_source*sin(theta)*cos(phi)
- y_target_source = r_target_source*sin(theta)*sin(phi)
- z_target_source = r_target_source*cos(theta)
-
-! save triangle for AVS or DX representation of epicenter
- r_target_source = 1.05d0
- delta_trgl = 1.8 * pi / 180.
- x_source_trgl1 = r_target_source*sin(theta+delta_trgl)*cos(phi-delta_trgl)
- y_source_trgl1 = r_target_source*sin(theta+delta_trgl)*sin(phi-delta_trgl)
- z_source_trgl1 = r_target_source*cos(theta+delta_trgl)
-
- x_source_trgl2 = r_target_source*sin(theta+delta_trgl)*cos(phi+delta_trgl)
- y_source_trgl2 = r_target_source*sin(theta+delta_trgl)*sin(phi+delta_trgl)
- z_source_trgl2 = r_target_source*cos(theta+delta_trgl)
-
- x_source_trgl3 = r_target_source*sin(theta-delta_trgl)*cos(phi)
- y_source_trgl3 = r_target_source*sin(theta-delta_trgl)*sin(phi)
- z_source_trgl3 = r_target_source*cos(theta-delta_trgl)
-
- ntotpoinAVS_DX = 2
- ntotspecAVS_DX = 1
-
- print *
- print *,'reading position of the receivers'
-
-! get number of stations from receiver file
- open(unit=11,file='DATA/STATIONS',iostat=ios,status='old',action='read')
- nrec = 0
- do while(ios == 0)
- read(11,"(a)",iostat=ios) dummystring
- if(ios == 0) nrec = nrec + 1
- enddo
- close(11)
-
- print *,'There are ',nrec,' three-component stations'
- print *
- if(nrec < 1) stop 'incorrect number of stations read - need at least one'
-
- allocate(station_name(nrec))
- allocate(network_name(nrec))
- allocate(stlat(nrec))
- allocate(stlon(nrec))
- allocate(stele(nrec))
- allocate(stbur(nrec))
-
- allocate(x_target(nrec))
- allocate(y_target(nrec))
- allocate(z_target(nrec))
-
-! loop on all the stations
- open(unit=11,file='DATA/STATIONS',status='old',action='read')
- do irec=1,nrec
- read(11,*) station_name(irec),network_name(irec),stlat(irec),stlon(irec),stele(irec),stbur(irec)
-
-! 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 the Cartesian position of the receiver (ignore ellipticity for AVS_DX)
-! points for the receivers are put at the surface for clarity (depth ignored)
- r_target=1.0d0
- x_target(irec) = r_target*dsin(theta)*dcos(phi)
- y_target(irec) = r_target*dsin(theta)*dsin(phi)
- z_target(irec) = r_target*dcos(theta)
-
- enddo
-
- close(11)
-
-! duplicate source to have right color normalization in AVS_DX
- ntotpoinAVS_DX = ntotpoinAVS_DX + 2*nrec + 1
- ntotspecAVS_DX = ntotspecAVS_DX + nrec + 1
-
-! write AVS or DX header with element data
-! add source and receivers (small AVS or DX lines)
-! duplicate source to have right color normalization in AVS_DX
- if(USE_OPENDX) then
- open(unit=11,file=trim(OUTPUT_FILES)//'/DX_source_receivers.dx',status='unknown')
- write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ntotpoinAVS_DX,' data follows'
- write(11,*) sngl(x_target_source),' ',sngl(y_target_source),' ',sngl(z_target_source)
- write(11,*) sngl(x_target_source+0.1*small_offset_source),' ', &
- sngl(y_target_source+0.1*small_offset_source),' ',sngl(z_target_source+0.1*small_offset_source)
- write(11,*) sngl(x_target_source+1.3*small_offset_source),' ', &
- sngl(y_target_source+1.3*small_offset_source),' ',sngl(z_target_source+1.3*small_offset_source)
- do ir=1,nrec
- write(11,*) sngl(x_target(ir)),' ',sngl(y_target(ir)),' ',sngl(z_target(ir))
- write(11,*) sngl(x_target(ir)+small_offset_receiver),' ', &
- sngl(y_target(ir)+small_offset_receiver),' ',sngl(z_target(ir)+small_offset_receiver)
- enddo
- write(11,*) 'object 2 class array type int rank 1 shape 2 items ',ntotspecAVS_DX,' data follows'
- write(11,*) '0 1'
- do ir=1,nrec
- write(11,*) 4+2*(ir-1)-1,' ',4+2*(ir-1)
- enddo
- write(11,*) '0 2'
- write(11,*) 'attribute "element type" string "lines"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
- write(11,*) '1.'
- do ir=1,nrec
- write(11,*) ' 255.'
- enddo
- write(11,*) ' 120.'
- write(11,*) 'attribute "dep" string "connections"'
- write(11,*) 'object "irregular connections irregular positions" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
- close(11)
- else
- open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_source_receivers.inp',status='unknown')
- write(11,*) ntotpoinAVS_DX,' ',ntotspecAVS_DX,' 0 1 0'
- write(11,*) '1 ',sngl(x_target_source),' ',sngl(y_target_source),' ',sngl(z_target_source)
- write(11,*) '2 ',sngl(x_target_source+0.1*small_offset_source),' ', &
- sngl(y_target_source+0.1*small_offset_source),' ',sngl(z_target_source+0.1*small_offset_source)
- write(11,*) '3 ',sngl(x_target_source+1.3*small_offset_source),' ', &
- sngl(y_target_source+1.3*small_offset_source),' ',sngl(z_target_source+1.3*small_offset_source)
- do ir=1,nrec
- write(11,*) 4+2*(ir-1),' ',sngl(x_target(ir)),' ',sngl(y_target(ir)),' ',sngl(z_target(ir))
- write(11,*) 4+2*(ir-1)+1,' ',sngl(x_target(ir)+small_offset_receiver),' ', &
- sngl(y_target(ir)+small_offset_receiver),' ',sngl(z_target(ir)+small_offset_receiver)
- enddo
- write(11,*) '1 1 line 1 2'
- do ir=1,nrec
- write(11,*) ir+1,' 1 line ',4+2*(ir-1),' ',4+2*(ir-1)+1
- enddo
- write(11,*) ir+1,' 1 line 1 3'
- write(11,*) '1 1'
- write(11,*) 'Zcoord, meters'
- write(11,*) '1 1.'
- do ir=1,nrec
- write(11,*) ir+1,' 255.'
- enddo
- write(11,*) ir+1,' 120.'
- close(11)
- endif
-
-! create a file with the epicenter only, represented as a triangle
-
-! write AVS or DX header with element data
- if(USE_OPENDX) then
- open(unit=11,file=trim(OUTPUT_FILES)//'/DX_epicenter.dx',status='unknown')
- write(11,*) 'object 1 class array type float rank 1 shape 3 items 3 data follows'
- write(11,*) sngl(x_source_trgl1),' ',sngl(y_source_trgl1),' ',sngl(z_source_trgl1)
- write(11,*) sngl(x_source_trgl2),' ',sngl(y_source_trgl2),' ',sngl(z_source_trgl2)
- write(11,*) sngl(x_source_trgl3),' ',sngl(y_source_trgl3),' ',sngl(z_source_trgl3)
- write(11,*) 'object 2 class array type int rank 1 shape 3 items 1 data follows'
- write(11,*) '0 1 2'
- write(11,*) 'attribute "element type" string "triangles"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items 1 data follows'
- write(11,*) '1.'
- write(11,*) 'attribute "dep" string "connections"'
- write(11,*) 'object "irregular connections irregular positions" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
- close(11)
- else
- open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_epicenter.inp',status='unknown')
- write(11,*) '3 1 0 1 0'
- write(11,*) '1 ',sngl(x_source_trgl1),' ',sngl(y_source_trgl1),' ',sngl(z_source_trgl1)
- write(11,*) '2 ',sngl(x_source_trgl2),' ',sngl(y_source_trgl2),' ',sngl(z_source_trgl2)
- write(11,*) '3 ',sngl(x_source_trgl3),' ',sngl(y_source_trgl3),' ',sngl(z_source_trgl3)
- write(11,*) '1 1 tri 1 2 3'
- write(11,*) '1 1'
- write(11,*) 'Zcoord, meters'
- write(11,*) '1 1.'
- close(11)
- endif
-
- end program combine_AVS_DX
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/combine_paraview_strain_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/combine_paraview_strain_data.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/combine_paraview_strain_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,303 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory - California Institute of Technology
-! (c) California Institute of Technology September 2006
-!
-! A signed non-commercial agreement is required to use this program.
-! Please check http://www.gps.caltech.edu/research/jtromp for details.
-! Free for non-commercial academic research ONLY.
-! This program is distributed WITHOUT ANY WARRANTY whatsoever.
-! Do not redistribute this program without written permission.
-!
-!=====================================================================
-
-program combine_paraview_movie_data
-
-! combines the database files on several slices.
-! the local database file needs to have been collected onto the frontend (copy_local_database.pl)
-
- implicit none
-
- include 'constants.h'
- include 'OUTPUT_FILES/values_from_mesher.h'
-
- integer fid,i,ipoint, ios, it,itstart,itstop,dit_movie
- integer iproc, num_node, npoint_all, nelement_all
- integer np, ne, npoint(1000), nelement(1000), n1, n2, n3, n4, n5, n6, n7, n8
-
- integer numpoin,nelement_local
-! real(kind=CUSTOM_REAL),dimension(NGLOBMAX_CRUST_MANTLE) :: xstore, ystore, zstore,datstore
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: xstore, ystore, zstore,datstore
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: SEEstore,SNNstore,SZZstore,SNEstore,SNZstore,SEZstore
- real(kind=CUSTOM_REAL) :: x, y, z, dat
- character(len=150) :: arg(7), prname, dimension_file
- character(len=150) :: mesh_file, local_element_file, local_data_file
- character(len=3) :: comp
- logical :: MOVIE_COARSE
-
- do i = 1,6
- call getarg(i,arg(i))
- if (i < 7 .and. trim(arg(i)) == '') then
- print *, ' '
- print *, ' Usage: xcombine_data nnodes dt_movie itstart itstop comp MOVIE_COARSE'
- print *, ' component can be SEE, SNE,SEZ,SNN,SNZ,SZZ,I1 or I2'
- print *, ' stored in the local directory as real(kind=CUSTOM_REAL) filename(NGLLX,NGLLY,NGLLZ,nspec) '
- print *, 'MOVIE_COARSE = 0 or 1 '
- stop ' Reenter command line options'
- endif
- enddo
-
-
- read(arg(1),*) num_node
- read(arg(2),*) dit_movie
- read(arg(3),*) itstart
- read(arg(4),*) itstop
- read(arg(5),*) comp
- read(arg(6),*) MOVIE_COARSE
-
- if(num_node>1000) stop 'change array sizes for num_node > 1000 and recompile xcombine_paraview_movie_data'
-
- print *, 'Number of nodes: ',num_node
- print *, ' '
- print *, 'Timeframes every ',dit_movie,'from: ',itstart,' to:',itstop
-
- ! figure out total number of points
- print *, 'Counting points'
- do iproc = 1, num_node
-
-
- ! print *, 'Counting elements: slice ', iproc-1
- write(prname,'(a,i6.6,a)') 'proc',iproc-1,'_'
-
- dimension_file = trim(prname) //'movie3D_info.txt'
-! print *, 'reading: ',trim(dimension_file)
- open(unit = 27,file = trim(dimension_file),status='old',action='read', iostat = ios)
- if (ios /= 0) stop 'Error opening file'
-
- read(27,*) npoint(iproc),nelement(iproc)
- close(27)
-
- enddo
-
- npoint_all = sum(npoint(1:num_node))
- nelement_all = sum(nelement(1:num_node))
- print *, 'Total number of points = ', npoint_all
- print *, 'Total number of elements = ', nelement_all
-
-
- do it = itstart, itstop, dit_movie
- print *, '----------- Timeframe ', it, '----------------'
-
- ! open paraview output mesh file
- write(mesh_file,'(a,a,a,i6.6,a)') 'movie3D_',trim(comp),'_it',it,'.mesh'
- call open_file_fd(trim(mesh_file)//char(0),fid)
-
- np = 0
-
- ! write point and scalar information
- print *,'writing point information'
- do iproc = 1, num_node
-
-
- ! print *, ' '
- !print *, 'Writing points: slice ', iproc-1,'npoints',npoint(iproc)
- write(prname,'(a,i6.6,a)') 'proc',iproc-1,'_'
-
- numpoin = 0
-
-
- if (iproc == 1) then
- call write_integer_fd(fid,npoint_all)
- endif
-
- open(unit = 27,file = trim(prname)//'movie3D_x.bin',status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) stop 'Error opening file x.bin'
- if (npoint(iproc)>0) then
- read(27) xstore(1:npoint(iproc))
- endif
- close(27)
-
- open(unit = 27,file = trim(prname)//'movie3D_y.bin',status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) stop 'Error opening file y.bin'
- if (npoint(iproc)>0) then
- read(27) ystore(1:npoint(iproc))
- endif
- close(27)
-
- open(unit = 27,file = trim(prname)//'movie3D_z.bin',status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) stop 'Error opening file z.bin'
- if (npoint(iproc)>0) then
- read(27) zstore(1:npoint(iproc))
- endif
- close(27)
-
- if( (comp /= 'SI1') .and. (comp /= 'SI2')) then
-!comp == 'SEE' .or. comp == 'SNN' .or. comp == 'SZZ' .or. comp == 'SEZ' .or. comp == 'SNZ' .or. comp == 'SNE') then
- write(local_data_file,'(a,a,i6.6,a)') 'movie3D_',comp,it,'.bin'
-
- !print *,'reading comp:',trim(prname)//trim(local_data_file)
-
- open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) stop 'Error opening file it.bin'
- if (npoint(iproc)>0) then
- read(27) datstore(1:npoint(iproc))
- endif
- close(27)
- elseif(comp == 'SI1' .or. comp == 'SI2') then
- write(local_data_file,'(a,i6.6,a)') 'movie3D_SEE',it,'.bin'
- !print *, iproc,'reading from file:'//trim(prname)//trim(local_data_file)
- !print *, 'reading from file:',local_data_file
- open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) stop 'Error opening file it.bin'
- if (npoint(iproc)>0) then
- read(27) SEEstore(1:npoint(iproc))
- endif
- close(27)
-
- write(local_data_file,'(a,i6.6,a)') 'movie3D_SNE',it,'.bin'
- !print *, 'reading from file:',local_data_file
- open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) stop 'Error opening file it.bin'
- if (npoint(iproc)>0) then
- read(27) SNEstore(1:npoint(iproc))
- endif
- close(27)
-
- write(local_data_file,'(a,i6.6,a)') 'movie3D_SEZ',it,'.bin'
- !print *, 'reading from file:',local_data_file
- open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) stop 'Error opening file it.bin'
- if (npoint(iproc)>0) then
- read(27) SEZstore(1:npoint(iproc))
- endif
- close(27)
-
- write(local_data_file,'(a,i6.6,a)') 'movie3D_SNN',it,'.bin'
- !print *, 'reading from file:',local_data_file
- open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) stop 'Error opening file it.bin'
- if (npoint(iproc)>0) then
- read(27) SNNstore(1:npoint(iproc))
- endif
- close(27)
-
- write(local_data_file,'(a,i6.6,a)') 'movie3D_SNZ',it,'.bin'
- !print *, 'reading from file:',local_data_file
- open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) stop 'Error opening file it.bin'
- if (npoint(iproc)>0) then
- read(27) SNZstore(1:npoint(iproc))
- endif
- close(27)
-
- write(local_data_file,'(a,i6.6,a)') 'movie3D_SZZ',it,'.bin'
- !print *, 'reading from file:',local_data_file
- open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) stop 'Error opening file it.bin'
- if (npoint(iproc)>0) then
- read(27) SZZstore(1:npoint(iproc))
- endif
- close(27)
- else
- stop 'unrecognized component'
- endif !strain or invariant
-
- datstore=datstore
- do ipoint=1,npoint(iproc)
- numpoin = numpoin + 1
- x = xstore(ipoint)
- y = ystore(ipoint)
- z = zstore(ipoint)
- dat = datstore(ipoint)
- call write_real_fd(fid,x)
- call write_real_fd(fid,y)
- call write_real_fd(fid,z)
- call write_real_fd(fid,dat)
- ! print *, 'point:',ipoint,x,y,z,dat
- enddo !
-
- if (numpoin /= npoint(iproc)) stop 'different number of points'
- np = np + npoint(iproc)
-
- enddo ! all slices for points
-
- if (np /= npoint_all) stop 'Error: Number of total points are not consistent'
- print *, 'Total number of points: ', np
- print *, ' '
-
- ne = 0
-! write element information
- print *, 'Writing element information'
- do iproc = 1, num_node
-
- ! print *, 'Reading slice ', iproc-1
- write(prname,'(a,i6.6,a)') 'proc',iproc-1,'_'
-
- if (iproc == 1) then
- np = 0
- else
- np = sum(npoint(1:iproc-1))
- endif
-
-
- local_element_file = trim(prname) // 'movie3D_elements.bin'
- open(unit = 27, file = trim(local_element_file), status = 'old', action='read',iostat = ios,form='unformatted')
- if (ios /= 0) stop 'Error opening file'
-
- ! print *, trim(local_element_file)
-
- if (iproc == 1) then
- if(MOVIE_COARSE) then
- call write_integer_fd(fid,nelement_all)
- else
- call write_integer_fd(fid,nelement_all*64)
- endif
- endif
-
- if(MOVIE_COARSE) then
- nelement_local = nelement(iproc)
- else
- nelement_local = nelement(iproc)*64
- endif
- do i = 1, nelement_local
- read(27) n1, n2, n3, n4, n5, n6, n7, n8
- n1 = n1+np
- n2 = n2+np
- n3 = n3+np
- n4 = n4+np
- n5 = n5+np
- n6 = n6+np
- n7 = n7+np
- n8 = n8+np
- call write_integer_fd(fid,n1)
- call write_integer_fd(fid,n2)
- call write_integer_fd(fid,n3)
- call write_integer_fd(fid,n4)
- call write_integer_fd(fid,n5)
- call write_integer_fd(fid,n6)
- call write_integer_fd(fid,n7)
- call write_integer_fd(fid,n8)
- !write(*,*) n1, n2, n3, n4, n5, n6, n7, n8
- enddo
- close(27)
-
- ne = ne + nelement(iproc)
-
- enddo ! num_node
- print *, 'Total number of elements: ', ne,' nelement_all',nelement_all
- if (ne /= nelement_all) stop 'Number of total elements are not consistent'
-
- call close_file_fd(fid)
-
- print *, 'Done writing '//trim(mesh_file)
- print *, ' '
-
- enddo ! timesteps
- print *, ' '
-
-end program combine_paraview_movie_data
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/combine_surf_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/combine_surf_data.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/combine_surf_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,349 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-program combine_surf_data
-
- ! combines the database files on several slices.
-
- implicit none
-
- include 'constants.h'
- include 'OUTPUT_FILES/values_from_mesher.h'
-
- integer,parameter :: MAX_NUM_NODES = 400
-
- integer i,j,k,ispec_surf,ios,it,num_node,njunk,ires,idim,iproc,njunk1,njunk2,njunk3,inx,iny
- character(len=150) :: arg(20),sline,filename,surfname,reg_name,belm_name, indir, outdir
- character(len=150) :: mesh_file, pt_mesh_file, em_mesh_file, command_name
- logical :: HIGH_RESOLUTION_MESH,FILE_ARRAY_IS_3D
- integer :: node_list(MAX_NUM_NODES),nspec(MAX_NUM_NODES),nglob(MAX_NUM_NODES)
-
- character(len=150) :: prname,dimen_name,prname2,nspec2D_file,dimension_file
- character(len=150) :: ibelm_surf_file,data_file,ibool_file
- integer :: nspec2D_moho_val, nspec2D_400_val, nspec2D_670_val, nspec_surf
- integer :: npoint,nelement, npoint_total,nelement_total, pfd,efd, np, ne, numpoin
- integer, allocatable :: ibelm_surf(:)
- real(kind=CUSTOM_REAL), allocatable :: data_2D(:,:,:), data_3D(:,:,:,:)
- integer ibool(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),num_ibool(NGLOB_CRUST_MANTLE)
- real(kind=CUSTOM_REAL),dimension(NGLOB_CRUST_MANTLE) :: xstore, ystore, zstore
- logical mask_ibool(NGLOB_CRUST_MANTLE)
- real dat, x, y, z
- integer ispec, iglob, iglob1, iglob2, iglob3, iglob4, n1, n2, n3, n4, nex
-
-
-! ------------------ program starts here -------------------
-
- do i = 1, 7
- call getarg(i,arg(i))
- if (i < 7 .and. trim(arg(i)) == '') then
- write(*,*) ' '
- write(*,*) ' Usage: xcombine_surf_data slice_list filename surfname input_dir output_dir high/low-resolution 2D/3D'
- write(*,*) ' filename.bin can be either'
- write(*,*) ' real(kind=CUSTOM_REAL) filename(NGLLX,NGLLY,NGLLZ,nspec)'
- write(*,*) ' or --- filename(NGLLX,NGLLY,NSPEC2D) where'
- write(*,*) ' filename=moho_kernel, d400_kernel, d670_kernel, CMB_kernel, or ICB_kernel'
- write(*,*) ' possible surface names: Moho, 400, 670, CMB, ICB'
- write(*,*) ' files have been collected in input_dir, output mesh file goes to output_dir '
- write(*,*) ' give 0 for low resolution and 1 for high resolution'
- write(*,*) ' give 0 for 2D and 1 for 3D filenames'
- write(*,*) ' region does not have to be specified'
- stop ' Reenter command line options'
- endif
- enddo
-
- if (NSPEC_CRUST_MANTLE < NSPEC_OUTER_CORE .or. NSPEC_CRUST_MANTLE < NSPEC_INNER_CORE) &
- stop 'This program needs that NSPEC_CRUST_MANTLE > NSPEC_OUTER_CORE and NSPEC_INNER_CORE'
-
- ! get slice list
- num_node = 0
- open(unit = 20, file = trim(arg(1)), status = 'unknown',iostat = ios)
- if (ios /= 0) stop 'Error opening file'
- do while (1 == 1)
- read(20,'(a)',iostat=ios) sline
- if (ios /= 0) exit
- read(sline,*,iostat=ios) njunk
- if (ios /= 0) exit
- num_node = num_node + 1
- node_list(num_node) = njunk
- enddo
- close(20)
- print *, 'Slice list: '
- print *, node_list(1:num_node)
- print *, ' '
-
- filename = arg(2)
-
- ! discontinutity surfaces
- surfname = arg(3)
- if (trim(surfname) == 'Moho' .or. trim(surfname) == '400' .or. trim(surfname) == '670') then
- reg_name = 'reg1_'
- belm_name = trim(reg_name)//'boundary_disc.bin'
- else if (trim(surfname) == 'CMB') then ! assume CMB_top
- reg_name = 'reg1_'
- belm_name = trim(reg_name)//'boundary.bin' ! use reg2_ibelm for CMB_bot
- else if (trim(surfname) == 'ICB') then ! assume ICB_top
- reg_name = 'reg2_'
- belm_name = trim(reg_name)//'boundary.bin' ! use reg3_ibelm for ICB_bot
- else
- stop 'surfname type can only be: Moho, 400, 670, CMB, and ICB'
- endif
-
- ! input and output dir
- indir= arg(4)
- outdir = arg(5)
-
- ! resolution
- read(arg(6),*) ires
- if (ires == 0) then
- HIGH_RESOLUTION_MESH = .false.
- inx = NGLLX-1; iny = NGLLY-1
- else
- HIGH_RESOLUTION_MESH = .true.
- inx = 1; iny = 1
- endif
-
- ! file dimension
- read(arg(7),*) idim
- if (idim == 0) then
- FILE_ARRAY_IS_3D = .false.
- else
- FILE_ARRAY_IS_3D = .true.
- endif
-
- dimen_name = trim(reg_name)//'array_dims.txt'
-
- ! figure out the total number of points/elements and allocate arrays
- write(prname,'(a,i6.6,a)') trim(indir)//'/proc',node_list(1),'_'
- nspec2D_file = trim(prname) // trim(belm_name)
-
- open(27,file=trim(nspec2D_file),status='old',form='unformatted')
- if (trim(surfname) == 'CMB' .or. trim(surfname) == 'ICB') then
- read(27) njunk
- read(27) njunk
- read(27) njunk
- read(27) njunk
- read(27) nspec_surf
- else
- read(27) nspec2D_moho_val,nspec2D_400_val,nspec2D_670_val
- if (trim(surfname) == 'Moho') nspec_surf = nspec2D_moho_val
- if (trim(surfname) == '400') nspec_surf = nspec2D_400_val
- if (trim(surfname) == '670') nspec_surf = nspec2D_670_val
- endif
- close(27)
- nex = int(dsqrt(nspec_surf*1.0d0))
- if (HIGH_RESOLUTION_MESH) then
- npoint = (nex*(NGLLX-1)+1) * (nex*(NGLLY-1)+1)
- nelement = nspec_surf * (NGLLX-1) * (NGLLY-1)
- else
- npoint = (nex+1) * (nex+1)
- nelement = nspec_surf
- endif
- npoint_total = npoint * num_node
- nelement_total = nelement * num_node
- print *, 'total number of spectral elements = ', nspec_surf
- print *, 'total number of points = ', npoint_total
- print *, 'total number of elements = ', nelement_total
-
- ! ========= write points and elements files ===================
- allocate(ibelm_surf(nspec_surf))
- do it = 1, num_node
- write(prname,'(a,i6.6,a)') trim(indir)//'/proc',node_list(it),'_'
- dimension_file = trim(prname) // trim(dimen_name)
- open(unit=27,file=trim(dimension_file),status='old',action='read', iostat = ios)
- if (ios /= 0) stop 'Error opening file'
- read(27,*) nspec(it)
- read(27,*) nglob(it)
- close(27)
- enddo
-
- if ( .not. FILE_ARRAY_IS_3D) then
- allocate(data_2D(NGLLX,NGLLY,nspec_surf))
- else
- allocate(data_3D(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE))
- endif
-
- ! open paraview output mesh file
- write(mesh_file,'(a,i1,a)') trim(outdir)//'/'//trim(filename)//'.surf'
- write(pt_mesh_file,'(a,i1,a)') trim(outdir)//'/'//trim(filename)//'_point.surf'
- write(em_mesh_file,'(a,i1,a)') trim(outdir)//'/'//trim(filename)//'_element.surf'
- command_name='rm -f '//trim(pt_mesh_file)//' '//trim(em_mesh_file)//' '//trim(mesh_file)
-
- call system(trim(command_name))
- call open_file_fd(trim(pt_mesh_file)//char(0),pfd)
- call open_file_fd(trim(em_mesh_file)//char(0),efd)
-
- np = 0
- ne = 0
- call write_integer_fd(pfd,npoint_total)
- call write_integer_fd(efd,nelement_total)
-
- ! loop over slices
-
- do it = 1, num_node
-
- iproc = node_list(it)
-
- print *, 'Reading slice ', iproc
- write(prname,'(a,i6.6,a)') trim(indir)//'/proc',iproc,'_'
- prname2 = trim(prname)//trim(reg_name)
-
- ! surface topology file
- ibelm_surf_file = trim(prname) // trim(belm_name)
- print *, trim(ibelm_surf_file)
- open(unit = 28,file = trim(ibelm_surf_file),status='old', iostat = ios, form='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(ibelm_surf_file); stop
- endif
- if (trim(surfname) == 'Moho' .or. trim(surfname) == '400' .or. trim(surfname) == '670') then
- read(28) njunk1,njunk2,njunk3
- if (trim(surfname) == 'Moho') then;
- read(28) ibelm_surf ! moho top
- else if (trim(surfname) == '400' .or. trim(surfname) == '670') then
- read(28) njunk ! moho top
- read(28) njunk ! moho bot
- if (trim(surfname) == '400') then
- read(28) ibelm_surf ! 400 top
- else
- read(28) njunk ! 400 top
- read(28) njunk ! 400 bot
- read(28) ibelm_surf ! 670 top
- endif
- endif
- else ! CMB or ICB
- read(28) njunk; read(28) njunk; read(28) njunk; read(28) njunk; read(28) njunk; read(28) njunk;
- read(28) njunk; read(28) njunk; read(28) njunk; read(28) njunk
- read(28) ibelm_surf
- endif
- close(28)
-
- ! datafile
- data_file = trim(prname2)//trim(filename)//'.bin'
- print *, trim(data_file)
- open(unit = 27,file = trim(data_file),status='old', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(data_file); stop
- endif
- if (FILE_ARRAY_IS_3D) then
- read(27) data_3D(:,:,:,1:nspec(it))
- else
- read(27) data_2D
- endif
- close(27)
-
- ! ibool file
- ibool_file = trim(prname2) // 'solver_data_2' // '.bin'
- print *, trim(ibool_file)
- open(unit = 28,file = trim(ibool_file),status='old', iostat = ios, form='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(ibool_file); stop
- endif
- read(28) xstore(1:nglob(it))
- read(28) ystore(1:nglob(it))
- read(28) zstore(1:nglob(it))
- read(28) ibool(:,:,:,1:nspec(it))
- close(28)
-
- mask_ibool(:) = .false.
- num_ibool(:) = 0
- numpoin = 0
- k = 1
- do ispec_surf=1,nspec_surf
- ispec = ibelm_surf(ispec_surf)
- do j = 1, NGLLY, iny
- do i = 1, NGLLX, inx
- iglob = ibool(i,j,k,ispec)
- if(.not. mask_ibool(iglob)) then
- numpoin = numpoin + 1
- x = xstore(iglob)
- y = ystore(iglob)
- z = zstore(iglob)
- call write_real_fd(pfd,x)
- call write_real_fd(pfd,y)
- call write_real_fd(pfd,z)
- if (FILE_ARRAY_IS_3D) then
- dat=data_3D(i,j,k,ispec)
- else
- dat=data_2D(i,j,ispec_surf)
- endif
- call write_real_fd(pfd,dat)
-! call write_real_fd(pfd,real(ispec_surf))
- mask_ibool(iglob) = .true.
- num_ibool(iglob) = numpoin
- endif
- enddo ! i
- enddo ! j
- enddo !ispec_surf
- if (numpoin /= npoint) stop 'Error: number of points are not consistent'
-
- ! write element info
- do ispec_surf = 1, nspec_surf
- ispec = ibelm_surf(ispec_surf)
- do j = 1, NGLLY-1, iny
- do i = 1, NGLLX-1, inx
- iglob1 = ibool(i,j,k,ispec)
- iglob2 = ibool(i+inx,j,k,ispec)
- iglob3 = ibool(i+inx,j+iny,k,ispec)
- iglob4 = ibool(i,j+iny,k,ispec)
-
- n1 = num_ibool(iglob1)+np-1
- n2 = num_ibool(iglob2)+np-1
- n3 = num_ibool(iglob3)+np-1
- n4 = num_ibool(iglob4)+np-1
-
- call write_integer_fd(efd,n1)
- call write_integer_fd(efd,n2)
- call write_integer_fd(efd,n3)
- call write_integer_fd(efd,n4)
-
- ne = ne + 1
-
- enddo
- enddo
- enddo
-
- np = np + numpoin
-
- enddo ! all slices for points
-
- if (np /= npoint_total) stop 'Error: Number of total points not consistent'
- if (ne /= nelement_total) stop 'Error: Number of total elements not consistent'
-
- call close_file_fd(pfd)
- call close_file_fd(efd)
-
- ! cat files
- command_name='cat '//trim(pt_mesh_file)//' '//trim(em_mesh_file)//' > '//trim(mesh_file)
- print *, ' '
- print *, 'cat mesh files ...'
- print *, trim(command_name)
- call system(trim(command_name))
-
- print *, 'Done writing '//trim(mesh_file)
- print *, ' '
-
-end program combine_surf_data
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/combine_vol_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/combine_vol_data.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/combine_vol_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,999 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-program combine_vol_data
-
- ! combines the database files on several slices.
- ! the local database file needs to have been collected onto the frontend (copy_local_database.pl)
-
- implicit none
-
- include 'constants.h'
- include 'OUTPUT_FILES/values_from_mesher.h'
-
- integer,parameter :: MAX_NUM_NODES = 1000
- integer iregion, ir, irs, ire, ires, pfd, efd
- character(len=256) :: sline, arg(7), filename, in_topo_dir, in_file_dir, outdir
- character(len=256) :: prname_topo, prname_file, dimension_file
- character(len=1038) :: command_name
- character(len=256) :: pt_mesh_file1, pt_mesh_file2, mesh_file, em_mesh_file, data_file, topo_file
- integer, dimension(MAX_NUM_NODES) :: node_list, nspec, nglob, npoint, nelement
- integer iproc, num_node, i,j,k,ispec, ios, it, di, dj, dk
- integer np, ne, njunk
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: data
- real(kind=CUSTOM_REAL),dimension(NGLOB_CRUST_MANTLE) :: xstore, ystore, zstore
- integer ibool(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE)
- integer num_ibool(NGLOB_CRUST_MANTLE)
- logical mask_ibool(NGLOB_CRUST_MANTLE), HIGH_RESOLUTION_MESH
- real x, y, z, dat
- integer numpoin, iglob, n1, n2, n3, n4, n5, n6, n7, n8
- integer iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
-
- ! instead of taking the first value which appears for a global point, average the values
- ! if there are more than one gll points for a global point (points on element corners, edges, faces)
- logical,parameter:: AVERAGE_GLOBALPOINTS = .false.
- integer:: ibool_count(NGLOB_CRUST_MANTLE)
- real(kind=CUSTOM_REAL):: ibool_dat(NGLOB_CRUST_MANTLE)
-
- ! note:
- ! if one wants to remove the topography and ellipticity distortion, you would run the mesher again
- ! but turning the flags: TOPOGRAPHY and ELLIPTICITY to .false.
- ! then, use those as topo files: proc***_array_dims.txt and proc***_solver_data_2.bin
- ! of course, this would also work by just turning ELLIPTICITY to .false. so that the CORRECT_ELLIPTICITY below
- ! becomes unneccessary
- !
- ! puts point locations back into a perfectly spherical shape by removing the ellipticity factor;
- ! useful for plotting spherical cuts at certain depths
- logical,parameter:: CORRECT_ELLIPTICITY = .false.
- integer :: nspl
- double precision :: rspl(NR),espl(NR),espl2(NR)
- logical,parameter :: ONE_CRUST = .false. ! if you want to correct a model with one layer only in PREM crust
-
-
- ! starts here--------------------------------------------------------------------------------------------------
- do i = 1, 7
- call getarg(i,arg(i))
- if (i < 7 .and. trim(arg(i)) == '') then
- print *, ' '
- print *, ' Usage: xcombine_vol_data slice_list filename input_topo_dir input_file_dir '
- print *, ' output_dir high/low-resolution [region]'
- print *, ' ***** Notice: now allow different input dir for topo and kernel files ******** '
- print *, ' expect to have the topology and filename.bin(NGLLX,NGLLY,NGLLZ,nspec) '
- print *, ' already collected to input_topo_dir and input_file_dir'
- print *, ' output mesh files (filename_points.mesh, filename_elements.mesh) go to output_dir '
- print *, ' give 0 for low resolution and 1 for high resolution'
- print *, ' if region is not specified, all 3 regions will be collected, otherwise, only collect regions specified'
- stop ' Reenter command line options'
- endif
- enddo
-
- if (NSPEC_CRUST_MANTLE < NSPEC_OUTER_CORE .or. NSPEC_CRUST_MANTLE < NSPEC_INNER_CORE) &
- stop 'This program needs that NSPEC_CRUST_MANTLE > NSPEC_OUTER_CORE and NSPEC_INNER_CORE'
-
- ! get region id
- if (trim(arg(7)) == '') then
- iregion = 0
- else
- read(arg(7),*) iregion
- endif
- if (iregion > 3 .or. iregion < 0) stop 'Iregion = 0,1,2,3'
- if (iregion == 0) then
- irs = 1
- ire = 3
- else
- irs = iregion
- ire = irs
- endif
-
- ! get slices id
- num_node = 0
- open(unit = 20, file = trim(arg(1)), status = 'old',iostat = ios)
- if (ios /= 0) then
- print*,'no file: ',trim(arg(1))
- stop 'Error opening slices file'
- endif
-
- do while (1 == 1)
- read(20,'(a)',iostat=ios) sline
- if (ios /= 0) exit
- read(sline,*,iostat=ios) njunk
- if (ios /= 0) exit
- num_node = num_node + 1
- node_list(num_node) = njunk
- enddo
- close(20)
- print *, 'slice list: '
- print *, node_list(1:num_node)
- print *, ' '
-
- ! file to collect
- filename = arg(2)
-
- ! input and output dir
- in_topo_dir= arg(3)
- in_file_dir= arg(4)
- outdir = arg(5)
-
- ! resolution
- read(arg(6),*) ires
- if (ires == 0) then
- HIGH_RESOLUTION_MESH = .false.
- di = NGLLX-1; dj = NGLLY-1; dk = NGLLZ-1
- else if( ires == 1 ) then
- HIGH_RESOLUTION_MESH = .true.
- di = 1; dj = 1; dk = 1
- else if( ires == 2 ) then
- HIGH_RESOLUTION_MESH = .false.
- di = (NGLLX-1)/2.0; dj = (NGLLY-1)/2.0; dk = (NGLLZ-1)/2.0
- endif
- if( HIGH_RESOLUTION_MESH ) then
- print *, ' high resolution ', HIGH_RESOLUTION_MESH
- else
- print *, ' low resolution ', HIGH_RESOLUTION_MESH
- endif
-
- ! sets up ellipticity splines in order to remove ellipticity from point coordinates
- if( CORRECT_ELLIPTICITY ) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
-
-
- do ir = irs, ire
- print *, '----------- Region ', ir, '----------------'
-
- ! open paraview output mesh file
- write(pt_mesh_file1,'(a,i1,a)') trim(outdir)//'/' // 'reg_',ir,'_'//trim(filename)//'_point1.mesh'
- write(pt_mesh_file2,'(a,i1,a)') trim(outdir)//'/' // 'reg_',ir,'_'//trim(filename)//'_point2.mesh'
- write(mesh_file,'(a,i1,a)') trim(outdir)//'/' // 'reg_',ir,'_'//trim(filename)//'.mesh'
- write(em_mesh_file,'(a,i1,a)') trim(outdir)//'/' // 'reg_',ir,'_'//trim(filename)//'_element.mesh'
-
- call open_file_fd(trim(pt_mesh_file1)//char(0),pfd)
- call open_file_fd(trim(em_mesh_file)//char(0),efd)
-
- ! figure out total number of points and elements for high-res mesh
-
- do it = 1, num_node
-
- iproc = node_list(it)
-
- print *, 'Reading slice ', iproc
- write(prname_topo,'(a,i6.6,a,i1,a)') trim(in_topo_dir)//'/proc',iproc,'_reg',ir,'_'
- write(prname_file,'(a,i6.6,a,i1,a)') trim(in_file_dir)//'/proc',iproc,'_reg',ir,'_'
-
-
- dimension_file = trim(prname_topo) //'array_dims.txt'
- open(unit = 27,file = trim(dimension_file),status='old',action='read', iostat = ios)
- if (ios /= 0) then
- print*,'error ',ios
- print*,'file:',trim(dimension_file)
- stop 'Error opening file'
- endif
-
- read(27,*) nspec(it)
- read(27,*) nglob(it)
- close(27)
- if (HIGH_RESOLUTION_MESH) then
- npoint(it) = nglob(it)
- nelement(it) = nspec(it) * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1)
- else if( ires == 0 ) then
- nelement(it) = nspec(it)
- else if (ires == 2 ) then
- nelement(it) = nspec(it) * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1) / 8
- endif
-
- enddo
-
- print *, 'nspec(it) = ', nspec(1:num_node)
- print *, 'nglob(it) = ', nglob(1:num_node)
-
- call write_integer_fd(efd,sum(nelement(1:num_node)))
-
- np = 0
- ne = 0
-
- ! write points information
- do it = 1, num_node
-
- iproc = node_list(it)
-
-
- print *, ' '
- print *, 'Reading slice ', iproc
- write(prname_topo,'(a,i6.6,a,i1,a)') trim(in_topo_dir)//'/proc',iproc,'_reg',ir,'_'
- write(prname_file,'(a,i6.6,a,i1,a)') trim(in_file_dir)//'/proc',iproc,'_reg',ir,'_'
-
- ! filename.bin
- data_file = trim(prname_file) // trim(filename) // '.bin'
- open(unit = 27,file = trim(data_file),status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print*,'error ',ios
- print*,'file:',trim(data_file)
- stop 'Error opening file'
- endif
-
- data(:,:,:,:) = -1.e10
- read(27) data(:,:,:,1:nspec(it))
- close(27)
-
- print *,trim(data_file)
- print *,' min/max value: ',minval(data(:,:,:,1:nspec(it))),maxval(data(:,:,:,1:nspec(it)))
- print *
-
- ! topology file
- topo_file = trim(prname_topo) // 'solver_data_2' // '.bin'
- open(unit = 28,file = trim(topo_file),status='old',action='read', iostat = ios, form='unformatted')
- if (ios /= 0) then
- print*,'error ',ios
- print*,'file:',trim(topo_file)
- stop 'Error opening file'
- endif
- xstore(:) = 0.0
- ystore(:) = 0.0
- zstore(:) = 0.0
- ibool(:,:,:,:) = -1
- read(28) xstore(1:nglob(it))
- read(28) ystore(1:nglob(it))
- read(28) zstore(1:nglob(it))
- read(28) ibool(:,:,:,1:nspec(it))
- close(28)
-
- print *, trim(topo_file)
-
-
- !average data on global points
- ibool_count(:) = 0
- ibool_dat(:) = 0.0
- if( AVERAGE_GLOBALPOINTS ) then
- do ispec=1,nspec(it)
- do k = 1, NGLLZ, dk
- do j = 1, NGLLY, dj
- do i = 1, NGLLX, di
- iglob = ibool(i,j,k,ispec)
-
- dat = data(i,j,k,ispec)
-
- ibool_dat(iglob) = ibool_dat(iglob) + dat
- ibool_count(iglob) = ibool_count(iglob) + 1
- enddo
- enddo
- enddo
- enddo
- do iglob=1,nglob(it)
- if( ibool_count(iglob) > 0 ) then
- ibool_dat(iglob) = ibool_dat(iglob)/ibool_count(iglob)
- endif
- enddo
- endif
-
- mask_ibool(:) = .false.
- num_ibool(:) = 0
- numpoin = 0
-
-
- ! write point file
- do ispec=1,nspec(it)
- do k = 1, NGLLZ, dk
- do j = 1, NGLLY, dj
- do i = 1, NGLLX, di
- iglob = ibool(i,j,k,ispec)
- if( iglob == -1 ) cycle
-
- ! takes the averaged data value for mesh
- if( AVERAGE_GLOBALPOINTS ) then
- if(.not. mask_ibool(iglob)) then
- numpoin = numpoin + 1
- x = xstore(iglob)
- y = ystore(iglob)
- z = zstore(iglob)
-
- ! remove ellipticity
- if( CORRECT_ELLIPTICITY ) call reverse_ellipticity(x,y,z,nspl,rspl,espl,espl2)
-
- !dat = data(i,j,k,ispec)
- dat = ibool_dat(iglob)
-
- call write_real_fd(pfd,x)
- call write_real_fd(pfd,y)
- call write_real_fd(pfd,z)
- call write_real_fd(pfd,dat)
-
- mask_ibool(iglob) = .true.
- num_ibool(iglob) = numpoin
- endif
- else
- if(.not. mask_ibool(iglob)) then
- numpoin = numpoin + 1
- x = xstore(iglob)
- y = ystore(iglob)
- z = zstore(iglob)
-
- ! remove ellipticity
- if( CORRECT_ELLIPTICITY ) call reverse_ellipticity(x,y,z,nspl,rspl,espl,espl2)
-
- dat = data(i,j,k,ispec)
- call write_real_fd(pfd,x)
- call write_real_fd(pfd,y)
- call write_real_fd(pfd,z)
- call write_real_fd(pfd,dat)
- mask_ibool(iglob) = .true.
- num_ibool(iglob) = numpoin
- endif
- endif
- enddo ! i
- enddo ! j
- enddo ! k
- enddo !ispec
-
- ! no way to check the number of points for low-res
- if (HIGH_RESOLUTION_MESH .and. numpoin /= npoint(it)) then
- print*,'region:',ir
- print*,'error number of points:',numpoin,npoint(it)
- stop 'different number of points (high-res)'
- else if (.not. HIGH_RESOLUTION_MESH) then
- npoint(it) = numpoin
- endif
-
- ! write elements file
- do ispec = 1, nspec(it)
- do k = 1, NGLLZ-1, dk
- do j = 1, NGLLY-1, dj
- do i = 1, NGLLX-1, di
- iglob1 = ibool(i,j,k,ispec)
- iglob2 = ibool(i+di,j,k,ispec)
- iglob3 = ibool(i+di,j+dj,k,ispec)
- iglob4 = ibool(i,j+dj,k,ispec)
- iglob5 = ibool(i,j,k+dk,ispec)
- iglob6 = ibool(i+di,j,k+dk,ispec)
- iglob7 = ibool(i+di,j+dj,k+dk,ispec)
- iglob8 = ibool(i,j+dj,k+dk,ispec)
- n1 = num_ibool(iglob1)+np-1
- n2 = num_ibool(iglob2)+np-1
- n3 = num_ibool(iglob3)+np-1
- n4 = num_ibool(iglob4)+np-1
- n5 = num_ibool(iglob5)+np-1
- n6 = num_ibool(iglob6)+np-1
- n7 = num_ibool(iglob7)+np-1
- n8 = num_ibool(iglob8)+np-1
- call write_integer_fd(efd,n1)
- call write_integer_fd(efd,n2)
- call write_integer_fd(efd,n3)
- call write_integer_fd(efd,n4)
- call write_integer_fd(efd,n5)
- call write_integer_fd(efd,n6)
- call write_integer_fd(efd,n7)
- call write_integer_fd(efd,n8)
- enddo
- enddo
- enddo
- enddo
-
- np = np + npoint(it)
- ne = ne + nelement(it)
-
- enddo ! all slices for points
-
- if (np /= sum(npoint(1:num_node))) stop 'Error: Number of total points are not consistent'
- if (ne /= sum(nelement(1:num_node))) stop 'Error: Number of total elements are not consistent'
-
- print *, 'Total number of points: ', np
- print *, 'Total number of elements: ', ne
-
- call close_file_fd(pfd)
- call close_file_fd(efd)
-
- ! add the critical piece: total number of points
- call open_file_fd(trim(pt_mesh_file2)//char(0),pfd)
- call write_integer_fd(pfd,np)
- call close_file_fd(pfd)
-
- command_name='cat '//trim(pt_mesh_file2)//' '//trim(pt_mesh_file1)//' '//trim(em_mesh_file)//' > '//trim(mesh_file)
- print *, ' '
- print *, 'cat mesh files: '
- print *, trim(command_name)
- call system(trim(command_name))
-
- enddo
-
- print *, 'Done writing mesh files'
- print *, ' '
-
-
-end program combine_vol_data
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-
- subroutine reverse_ellipticity(x,y,z,nspl,rspl,espl,espl2)
-
- implicit none
-
- include "constants.h"
-
- real(kind=CUSTOM_REAL) :: x,y,z
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
- double precision x1,y1,z1
-
- double precision ell
- double precision r,theta,phi,factor
- double precision cost,p20
-
- ! gets spherical coordinates
- x1 = x
- y1 = y
- z1 = z
- call xyz_2_rthetaphi_dble(x1,y1,z1,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
-
- ! removes ellipticity factor
- x = x / factor
- y = y / factor
- z = z / factor
-
- end subroutine reverse_ellipticity
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! copy from make_ellipticity.f90 to avoid compiling issues
-
- 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
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! copy from model_prem.f90 to avoid compiling issues
-
- 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
-
- ! compute real physical radius in meters
- r = x * R_EARTH
-
- ! calculates density according to radius
- 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
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! copy from intgrl.f90 to avoid compiling issues
-
-
- 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
- double precision, parameter :: third = 1.0d0/3.0d0
- double precision, parameter :: fifth = 1.0d0/5.0d0
- double precision, parameter :: sixth = 1.0d0/6.0d0
-
- double precision rji,yprime(640)
- double precision s1l,s2l,s3l
-
- integer i,j,n,kdis(28)
- integer ndis,nir1
-
-
-
- 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)
- s1l = s1(j)
- s2l = s2(j)
- s3l = s3(j)
- sum = sum + r(j)*r(j)*rji*(f(j) &
- + rji*(0.5d0*s1l + rji*(third*s2l + rji*0.25d0*s3l))) &
- + 2.0d0*r(j)*rji*rji*(0.5d0*f(j) + rji*(third*s1l + rji*(0.25d0*s2l + rji*fifth*s3l))) &
- + rji*rji*rji*(third*f(j) + rji*(0.25d0*s1l + rji*(fifth*s2l + rji*sixth*s3l)))
- 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
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! copy from spline_routines.f90 to avoid compiling issues
-
-! 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
-
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! copy from rthetaphi_xyz.f90 to avoid compiling issues
-
-
- 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*xmesh + ymesh*ymesh + zmesh*zmesh)
-
- end subroutine xyz_2_rthetaphi_dble
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/comp_source_spectrum.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/comp_source_spectrum.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/comp_source_spectrum.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- 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/comp_source_time_function.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/comp_source_time_function.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/comp_source_time_function.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,64 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- 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
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- double precision function comp_source_time_function_rickr(t,f0)
-
- implicit none
-
- include "constants.h"
-
- double precision t,f0
-
- ! ricker
- comp_source_time_function_rickr = (1.d0 - 2.d0*PI*PI*f0*f0*t*t ) &
- * exp( -PI*PI*f0*f0*t*t )
-
- !!! another source time function they have called 'ricker' in some old papers,
- !!! e.g., 'Finite-Frequency Kernels Based on Adjoint Methods' by Liu & Tromp, BSSA (2006)
- !!! in order to benchmark those simulations, the following formula is needed.
- ! comp_source_time_function_rickr = -2.d0*PI*PI*f0*f0*f0*t * exp(-PI*PI*f0*f0*t*t)
-
- end function comp_source_time_function_rickr
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_add_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_add_sources.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_add_sources.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,433 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_add_sources(myrank,NSOURCES, &
- accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank,NSOURCES
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- accel_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES) :: sourcearrays
-
- double precision, dimension(NSOURCES) :: tshift_cmt,hdur_gaussian
-
- double precision :: DT,t0
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
- integer :: it
-
- ! needed for point force sources
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision, dimension(NDIM,NDIM,NSOURCES) :: nu_source
- double precision, dimension(NSOURCES) :: hdur
-
- ! local parameters
- double precision :: stf
- real(kind=CUSTOM_REAL) :: stf_used
- integer :: isource,i,j,k,iglob,ispec
- double precision, external :: comp_source_time_function
- double precision :: f0
- double precision, external :: comp_source_time_function_rickr
-
- do isource = 1,NSOURCES
-
-
- ! add only if this proc carries the source
- if(myrank == islice_selected_source(isource)) then
-
- if(USE_FORCE_POINT_SOURCE) then
-
- ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
- iglob = ibool_crust_mantle(nint(xi_source(isource)), &
- nint(eta_source(isource)), &
- nint(gamma_source(isource)), &
- ispec_selected_source(isource))
-
- f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
-
- !if (it == 1 .and. myrank == 0) then
- ! write(IMAIN,*) 'using a source of dominant frequency ',f0
- ! write(IMAIN,*) 'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
- ! write(IMAIN,*) 'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
- !endif
-
- ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
- stf_used = FACTOR_FORCE_SOURCE * comp_source_time_function_rickr(dble(it-1)*DT-t0-tshift_cmt(isource),f0)
-
- ! we use a force in a single direction along one of the components:
- ! x/y/z or E/N/Z-direction would correspond to 1/2/3 = COMPONENT_FORCE_SOURCE
- ! e.g. nu_source(3,:) here would be a source normal to the surface (z-direction).
- accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
- + sngl( nu_source(COMPONENT_FORCE_SOURCE,:,isource) ) * stf_used
-
- else
-
- stf = comp_source_time_function(dble(it-1)*DT-t0-tshift_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
- ispec = ispec_selected_source(isource)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool_crust_mantle(i,j,k,ispec)
-
- accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
- + sourcearrays(:,i,j,k,isource)*stf_used
-
- enddo
- enddo
- enddo
-
- endif ! USE_FORCE_POINT_SOURCE
-
- endif
-
- enddo
-
- end subroutine compute_add_sources
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine compute_add_sources_adjoint(myrank,nrec, &
- nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
- accel_crust_mantle,adj_sourcearrays, &
- nu,xi_receiver,eta_receiver,gamma_receiver, &
- xigll,yigll,zigll,ibool_crust_mantle, &
- islice_selected_rec,ispec_selected_rec, &
- NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
- it,it_begin,station_name,network_name,DT)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank,nrec,nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC
-
- real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- accel_crust_mantle
-
- real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ,nadj_rec_local,NTSTEP_BETWEEN_READ_ADJSRC) :: &
- adj_sourcearrays
-
- double precision, dimension(NDIM,NDIM,nrec) :: nu
- double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLY) :: yigll
- double precision, dimension(NGLLZ) :: zigll
- double precision :: DT
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
-
- integer NSTEP_SUB_ADJ
- integer, dimension(NSTEP_SUB_ADJ) :: iadjsrc_len
- integer, dimension(NSTEP_SUB_ADJ,2) :: iadjsrc ! to read input in chunks
- integer, dimension(NSTEP) :: iadj_vec
-
- integer :: it,it_begin,itime
-
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- ! local parameters
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearray
- integer :: irec,irec_local,i,j,k,iglob,it_sub_adj
- character(len=150) :: adj_source_file
- logical :: ibool_read_adj_arrays
-
- ! figure out if we need to read in a chunk of the adjoint source at this timestep
- it_sub_adj = ceiling( dble(it)/dble(NTSTEP_BETWEEN_READ_ADJSRC) ) !chunk_number
- ibool_read_adj_arrays = (((it == it_begin) .or. (mod(it-1,NTSTEP_BETWEEN_READ_ADJSRC) == 0)) &
- .and. (nadj_rec_local > 0))
-
- ! needs to read in a new chunk/block of the adjoint source
- if(ibool_read_adj_arrays) then
-
- ! temporary source array
- allocate(adj_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NTSTEP_BETWEEN_READ_ADJSRC))
- adj_sourcearray = 0._CUSTOM_REAL
-
- irec_local = 0
- do irec = 1, nrec
- ! check that the source slice number is okay
- if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROCTOT_VAL-1) then
- if(islice_selected_rec(irec) < 0) call exit_MPI(myrank,'islice < 0')
- if(islice_selected_rec(irec) > NPROCTOT_VAL-1) call exit_MPI(myrank,'islice > NPROCTOT_VAL-1')
- call exit_MPI(myrank,'now: something is wrong with the source slice number in adjoint simulation')
- endif
- ! compute source arrays
- if(myrank == islice_selected_rec(irec)) then
- irec_local = irec_local + 1
-
- ! reads in **sta**.**net**.**LH**.adj files
- adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
- call compute_arrays_source_adjoint(myrank,adj_source_file, &
- xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
- nu(:,:,irec),adj_sourcearray, xigll,yigll,zigll,iadjsrc_len(it_sub_adj), &
- iadjsrc,it_sub_adj,NSTEP_SUB_ADJ,NTSTEP_BETWEEN_READ_ADJSRC,DT)
-
- ! stores source array
- ! note: the adj_sourcearrays has a time stepping from 1 to NTSTEP_BETWEEN_READ_ADJSRC
- ! this gets overwritten every time a new block/chunk is read in
- do itime = 1,NTSTEP_BETWEEN_READ_ADJSRC
- adj_sourcearrays(:,:,:,:,irec_local,itime) = adj_sourcearray(:,:,:,:,itime)
- enddo
-
- endif
- enddo
- if(irec_local /= nadj_rec_local) &
- call exit_MPI(myrank,'irec_local /= nadj_rec_local in adjoint simulation')
-
- deallocate(adj_sourcearray)
-
- endif
-
- irec_local = 0
- do irec = 1,nrec
-
- ! adds source (only if this proc carries the source)
- if(myrank == islice_selected_rec(irec)) then
- irec_local = irec_local + 1
-
- ! adds source contributions
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec))
-
-
- ! adds adjoint source acting at this time step (it):
- !
- ! note: we use index iadj_vec(it) which is the corresponding time step
- ! for the adjoint source acting at this time step (it)
- !
- ! see routine: setup_sources_receivers_adjindx() how this adjoint index array is set up
- !
- ! e.g. total length NSTEP = 3000, chunk length NTSTEP_BETWEEN_READ_ADJSRC= 1000
- ! then for it=1,..1000, first block has iadjsrc(1,1) with start = 2001 and end = 3000;
- ! corresponding iadj_vec(it) goes from
- ! iadj_vec(1) = 1000, iadj_vec(2) = 999 to iadj_vec(1000) = 1,
- ! that is, originally the idea was
- ! adj_sourcearrays(.. iadj_vec(1) ) corresponds to adjoint source trace at time index 3000
- ! adj_sourcearrays(.. iadj_vec(2) ) corresponds to adjoint source trace at time index 2999
- ! ..
- ! adj_sourcearrays(.. iadj_vec(1000) ) corresponds to adjoint source trace at time index 2001
- ! then a new block will be read, etc, and it is going down till to adjoint source trace at time index 1
- !
- ! now comes the tricky part:
- ! adjoint source traces are based on the seismograms from the forward run;
- ! such seismograms have a time step index 1 which corresponds to time -t0
- ! then time step index 2 which corresponds to -t0 + DT, and
- ! the last time step in the file at time step NSTEP corresponds to time -t0 + (NSTEP-1)*DT
- ! (see how we add the sources to the simulation in compute_add_sources() and
- ! how we write/save the seismograms and wavefields at the end of the time loop).
- !
- ! then you use that seismogram and take e.g. the velocity of it for a travetime adjoint source
- !
- ! now we read it in again, and remember the last time step in
- ! the file at NSTEP corresponds to -t0 + (NSTEP-1)*DT
- !
- ! the same time step is saved for the forward wavefields to reconstruct them;
- ! however, the Newark time scheme acts at the very beginning of this time loop
- ! such that we have the backward/reconstructed wavefield updated by
- ! a single time step into the direction -DT and b_displ(it=1) would corresponds to -t0 + (NSTEP-1)*DT - DT
- ! after the Newark (predictor) time step update.
- ! however, we will read the backward/reconstructed wavefield at the end of the first time loop,
- ! such that b_displ(it=1) corresponds to -t0 + (NSTEP-1)*DT (which is the one saved in the files).
- !
- ! for the kernel calculations, we want:
- ! adjoint wavefield at time t, starting from 0 to T
- ! and forward wavefield at time T-t, starting from T down to 0
- ! let's say time 0 corresponds to -t0 = -t0 + (it - 1)*DT at it=1
- ! and time T corresponds to -t0 + (NSTEP-1)*DT at it = NSTEP
- !
- ! as seen before, the time for the forward wavefield b_displ(it=1) would then
- ! correspond to time -t0 + (NSTEP-1)*DT - DT, which is T - DT.
- ! the corresponding time for the adjoint wavefield thus would be 0 + DT
- ! and the adjoint source index would be iadj_vec(it+1)
- ! however, iadj_vec(it+1) which would go from 999 down to 0. 0 is out of bounds.
- ! we thus would have to read in the adjoint source trace beginning from 2999 down to 0.
- ! index 0 is not defined in the adjoint source trace, and would be set to zero.
- !
- ! however, since this complicates things, we read the backward/reconstructed
- ! wavefield at the end of the first time loop, such that b_displ(it=1) corresponds to -t0 + (NSTEP-1)*DT.
- ! assuming that until that end the backward/reconstructed wavefield and adjoint fields
- ! have a zero contribution to adjoint kernels.
- accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
- + adj_sourcearrays(:,i,j,k,irec_local,iadj_vec(it))
-
- enddo
- enddo
- enddo
- endif
-
- enddo
-
-
- end subroutine compute_add_sources_adjoint
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
- b_accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank,NSOURCES,NSTEP
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_accel_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES) :: sourcearrays
-
- double precision, dimension(NSOURCES) :: tshift_cmt,hdur_gaussian
-
- double precision :: DT,t0
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
- integer :: it
- ! needed for point force sources
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision, dimension(NDIM,NDIM,NSOURCES) :: nu_source
- double precision, dimension(NSOURCES) :: hdur
-
- ! local parameters
- double precision :: stf
- real(kind=CUSTOM_REAL) :: stf_used
- integer :: isource,i,j,k,iglob,ispec
- double precision, external :: comp_source_time_function
- double precision :: f0
- double precision, external :: comp_source_time_function_rickr
-
- do isource = 1,NSOURCES
-
- ! add the source (only if this proc carries the source)
- if(myrank == islice_selected_source(isource)) then
-
-! note on backward/reconstructed wavefields:
-! time for b_displ( it ) corresponds to (NSTEP - (it-1) - 1 )*DT - t0 ...
-! as we start with saved wavefields b_displ( 1 ) = displ( NSTEP ) which correspond
-! to a time (NSTEP - 1)*DT - t0
-! (see sources for simulation_type 1 and seismograms)
-!
-! now, at the beginning of the time loop, the numerical Newmark time scheme updates
-! the wavefields, that is b_displ( it=1) would correspond to time (NSTEP -1 - 1)*DT - t0.
-! however, we read in the backward/reconstructed wavefields at the end of the Newmark time scheme
-! in the first (it=1) time loop.
-! this leads to the timing (NSTEP-(it-1)-1)*DT-t0-tshift_cmt for the source time function here
-
- if(USE_FORCE_POINT_SOURCE) then
-
- ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
- iglob = ibool_crust_mantle(nint(xi_source(isource)), &
- nint(eta_source(isource)), &
- nint(gamma_source(isource)), &
- ispec_selected_source(isource))
-
- f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
-
- !if (it == 1 .and. myrank == 0) then
- ! write(IMAIN,*) 'using a source of dominant frequency ',f0
- ! write(IMAIN,*) 'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
- ! write(IMAIN,*) 'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
- !endif
-
- ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
- stf_used = FACTOR_FORCE_SOURCE * comp_source_time_function_rickr(dble(NSTEP-it)*DT-t0-tshift_cmt(isource),f0)
-
- ! e.g. we use nu_source(3,:) here if we want a source normal to the surface.
- ! note: time step is now at NSTEP-it
- b_accel_crust_mantle(:,iglob) = b_accel_crust_mantle(:,iglob) &
- + sngl( nu_source(COMPONENT_FORCE_SOURCE,:,isource) ) * stf_used
-
- else
-
- ! see note above: time step corresponds now to NSTEP-it
- stf = comp_source_time_function(dble(NSTEP-it)*DT-t0-tshift_cmt(isource),hdur_gaussian(isource))
-
- ! 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
- ispec = ispec_selected_source(isource)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool_crust_mantle(i,j,k,ispec)
-
- b_accel_crust_mantle(:,iglob) = b_accel_crust_mantle(:,iglob) &
- + sourcearrays(:,i,j,k,isource)*stf_used
-
- enddo
- enddo
- enddo
-
- endif ! USE_FORCE_POINT_SOURCE
-
- endif
-
- enddo
-
- end subroutine compute_add_sources_backward
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_arrays_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_arrays_source.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_arrays_source.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,587 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_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_source_adjoint(myrank, adj_source_file, &
- xi_receiver,eta_receiver,gamma_receiver, nu,adj_sourcearray, &
- xigll,yigll,zigll,NSTEP_BLOCK,iadjsrc,it_sub_adj,NSTEP_SUB_ADJ, &
- NTSTEP_BETWEEN_READ_ADJSRC,DT)
-
- implicit none
-
- include 'constants.h'
-
-! input -- notice here NSTEP_BLOCK is different from the NSTEP in the main program
-! instead NSTEP_BLOCK = iadjsrc_len(it_sub_adj), the length of this specific block
-
- integer myrank, NSTEP_BLOCK
-
- double precision xi_receiver, eta_receiver, gamma_receiver
- double precision DT
-
- 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(NDIM,NGLLX,NGLLY,NGLLZ,NTSTEP_BETWEEN_READ_ADJSRC)
-
- ! 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,parameter :: scale_displ_inv = 1.d0/R_EARTH
-
- double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
- hgammar(NGLLZ), hpgammar(NGLLZ)
- real(kind=CUSTOM_REAL) :: adj_src(NDIM,NSTEP_BLOCK),adj_src_u(NDIM,NSTEP_BLOCK)
-
- integer icomp, itime, i, j, k, ios
- integer it_start,it_end,index_i
- real(kind=CUSTOM_REAL) :: junk
- !character(len=3),dimension(NDIM) :: comp = (/ "LHN", "LHE", "LHZ" /)
- character(len=3),dimension(NDIM) :: comp
- character(len=150) :: filename
- character(len=2) :: bic
-
-! by Ebru
- call band_instrument_code(DT,bic)
- comp(1) = bic(1:2)//'N'
- comp(2) = bic(1:2)//'E'
- comp(3) = bic(1:2)//'Z'
-!
-
- ! (sub)trace start and end
- ! reading starts in chunks of NSTEP_BLOCK from the end of the trace,
- ! i.e. as an example: total length NSTEP = 3000, chunk length NSTEP_BLOCK= 1000
- ! then it will read in first it_start=2001 to it_end=3000,
- ! second time, it will be it_start=1001 to it_end=2000 and so on...
- it_start = iadjsrc(it_sub_adj,1)
- it_end = iadjsrc(it_sub_adj,1)+NSTEP_BLOCK-1
-
-
- ! unfortunately, things become more tricky because of the Newark time scheme at
- ! the very beginning of the time loop. however, when we read in the backward/reconstructed
- ! wavefields at the end of the first time loop, we can use the adjoint source index from 3000 down to 1.
- !
- ! see the comment on where we add the adjoint source (compute_add_sources_adjoint()).
- !
- ! otherwise,
- ! we would have to shift this indices by minus 1, to read in the adjoint source trace between 0 to 2999.
- ! since 0 index is out of bounds, we would have to put that adjoint source displacement artifically to zero
- !
- ! here now, it_start is now 2001 and it_end = 3000, then 1001 to 2000, then 1 to 1000.
- it_start = it_start
- it_end = it_end
-
- adj_src = 0._CUSTOM_REAL
- do icomp = 1, NDIM
-
- ! opens adjoint component file
- filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
- open(unit=IIN,file=trim(filename),status='old',action='read',iostat=ios)
-
- ! note: adjoint source files must be available for all three components E/N/Z, even
- ! if a component is just zeroed out
- if (ios /= 0) then
- ! adjoint source file not found
- ! stops simulation
- call exit_MPI(myrank,&
- 'file '//trim(filename)//' not found, please check with your STATIONS_ADJOINT file')
- endif
- !if (ios /= 0) cycle ! cycles to next file
-
- ! jumps over unused trace length
- do itime =1,it_start-1
- read(IIN,*,iostat=ios) junk,junk
- if( ios /= 0) &
- call exit_MPI(myrank,&
- 'file '//trim(filename)//' has wrong length, please check with your simulation duration')
- enddo
-
- ! reads in (sub)trace
- do itime = it_start,it_end
-
- ! index will run from 1 to NSTEP_BLOCK
- index_i = itime - it_start + 1
-
- ! would skip read and set source artifically to zero if out of bounds, see comments above
- if( it_start == 0 .and. itime == 0 ) then
- adj_src(icomp,1) = 0._CUSTOM_REAL
- cycle
- endif
-
- ! reads in adjoint source trace
- !read(IIN,*,iostat=ios) junk, adj_src(icomp,itime-it_start+1)
- read(IIN,*,iostat=ios) junk, adj_src(icomp,index_i)
-
- if( ios /= 0) &
- call exit_MPI(myrank, &
- 'file '//trim(filename)//' has wrong length, please check with your simulation duration')
- enddo
-
- close(IIN)
-
- enddo
-
- ! non-dimensionalize
- adj_src = adj_src*scale_displ_inv
-
- ! rotates to cartesian
- do itime = 1, NSTEP_BLOCK
- adj_src_u(:,itime) = nu(1,:) * adj_src(1,itime) &
- + nu(2,:) * adj_src(2,itime) &
- + nu(3,:) * adj_src(3,itime)
- enddo
-
- ! receiver interpolators
- 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)
-
- ! adds interpolated source contribution to all GLL points within this element
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- do itime = 1, NSTEP_BLOCK
- adj_sourcearray(:,i,j,k,itime) = hxir(i) * hetar(j) * hgammar(k) * adj_src_u(:,itime)
- enddo
- enddo
- enddo
- enddo
-
-
-end subroutine compute_arrays_source_adjoint
-
-! =======================================================================
-
-! compute the integrated derivatives of source parameters (M_jk and X_s)
-
-subroutine compute_adj_source_frechet(displ_s,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- eps_s,eps_m_s,eps_m_l_s, &
- hxir,hetar,hgammar,hpxir,hpetar,hpgammar, hprime_xx,hprime_yy,hprime_zz, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
-
- implicit none
-
- include 'constants.h'
-
- ! input
- real(kind=CUSTOM_REAL) :: displ_s(NDIM,NGLLX,NGLLY,NGLLZ)
- double precision :: Mxx, Myy, Mzz, Mxy, Mxz, Myz
- ! output
- real(kind=CUSTOM_REAL) :: eps_s(NDIM,NDIM), eps_m_s, eps_m_l_s(NDIM)
-
- ! auxilliary
- double precision :: hxir(NGLLX), hetar(NGLLY), hgammar(NGLLZ), &
- hpxir(NGLLX),hpetar(NGLLY),hpgammar(NGLLZ)
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-
-! local variables
- real(kind=CUSTOM_REAL) :: tempx1l,tempx2l,tempx3l, tempy1l,tempy2l,tempy3l, &
- tempz1l,tempz2l,tempz3l, hp1, hp2, hp3, &
- xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl, &
- duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl, &
- xix_s,xiy_s,xiz_s,etax_s,etay_s,etaz_s,gammax_s,gammay_s,gammaz_s, &
- hlagrange_xi, hlagrange_eta, hlagrange_gamma, hlagrange
-
- real(kind=CUSTOM_REAL) :: eps(NDIM,NDIM), eps_array(NDIM,NDIM,NGLLX,NGLLY,NGLLZ), &
- eps_m_array(NGLLX,NGLLY,NGLLZ)
-
- integer i,j,k,l
-
-
-! first compute the strain at all the GLL points of the source element
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- tempy1l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
-
- tempz1l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- tempx1l = tempx1l + displ_s(1,l,j,k)*hp1
- tempy1l = tempy1l + displ_s(2,l,j,k)*hp1
- tempz1l = tempz1l + displ_s(3,l,j,k)*hp1
-
- hp2 = hprime_yy(j,l)
- tempx2l = tempx2l + displ_s(1,i,l,k)*hp2
- tempy2l = tempy2l + displ_s(2,i,l,k)*hp2
- tempz2l = tempz2l + displ_s(3,i,l,k)*hp2
-
- hp3 = hprime_zz(k,l)
- tempx3l = tempx3l + displ_s(1,i,j,l)*hp3
- tempy3l = tempy3l + displ_s(2,i,j,l)*hp3
- tempz3l = tempz3l + displ_s(3,i,j,l)*hp3
- enddo
-
-! dudx
- xixl = xix(i,j,k)
- xiyl = xiy(i,j,k)
- xizl = xiz(i,j,k)
- etaxl = etax(i,j,k)
- etayl = etay(i,j,k)
- etazl = etaz(i,j,k)
- gammaxl = gammax(i,j,k)
- gammayl = gammay(i,j,k)
- gammazl = gammaz(i,j,k)
-
- 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
-
-! strain eps_jk
- eps(1,1) = duxdxl
- eps(1,2) = (duxdyl + duydxl) / 2
- eps(1,3) = (duxdzl + duzdxl) / 2
- eps(2,2) = duydyl
- eps(2,3) = (duydzl + duzdyl) / 2
- eps(3,3) = duzdzl
- eps(2,1) = eps(1,2)
- eps(3,1) = eps(1,3)
- eps(3,2) = eps(2,3)
-
- eps_array(:,:,i,j,k) = eps(:,:)
-
-! Mjk eps_jk
- eps_m_array(i,j,k) = Mxx * eps(1,1) + Myy * eps(2,2) + Mzz * eps(3,3) + &
- 2 * (Mxy * eps(1,2) + Mxz * eps(1,3) + Myz * eps(2,3))
-
- enddo
- enddo
- enddo
-
- ! interpolate the strain eps_s(:,:) from eps_array(:,:,i,j,k)
- eps_s = 0.; eps_m_s=0.;
- xix_s = 0.; xiy_s = 0.; xiz_s = 0.
- etax_s = 0.; etay_s = 0.; etaz_s = 0.
- gammax_s = 0.; gammay_s = 0.; gammaz_s = 0.
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- hlagrange = hxir(i)*hetar(j)*hgammar(k)
-
- eps_s(1,1) = eps_s(1,1) + eps_array(1,1,i,j,k)*hlagrange
- eps_s(1,2) = eps_s(1,2) + eps_array(1,2,i,j,k)*hlagrange
- eps_s(1,3) = eps_s(1,3) + eps_array(1,3,i,j,k)*hlagrange
- eps_s(2,2) = eps_s(2,2) + eps_array(2,2,i,j,k)*hlagrange
- eps_s(2,3) = eps_s(2,3) + eps_array(2,3,i,j,k)*hlagrange
- eps_s(3,3) = eps_s(3,3) + eps_array(3,3,i,j,k)*hlagrange
-
- xix_s = xix_s + xix(i,j,k)*hlagrange
- xiy_s = xiy_s + xiy(i,j,k)*hlagrange
- xiz_s = xiz_s + xiz(i,j,k)*hlagrange
- etax_s = etax_s + etax(i,j,k)*hlagrange
- etay_s = etay_s + etay(i,j,k)*hlagrange
- etaz_s = etaz_s + etaz(i,j,k)*hlagrange
- gammax_s = gammax_s + gammax(i,j,k)*hlagrange
- gammay_s = gammay_s + gammay(i,j,k)*hlagrange
- gammaz_s = gammaz_s + gammaz(i,j,k)*hlagrange
-
- eps_m_s = eps_m_s + eps_m_array(i,j,k)*hlagrange
- enddo
- enddo
- enddo
-
-! for completion purpose, not used in specfem3D.f90
- eps_s(2,1) = eps_s(1,2)
- eps_s(3,1) = eps_s(1,3)
- eps_s(3,2) = eps_s(2,3)
-
-! compute the gradient of M_jk * eps_jk, and then interpolate it
-
- eps_m_l_s = 0.
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- hlagrange_xi = hpxir(i)*hetar(j)*hgammar(k)
- hlagrange_eta = hxir(i)*hpetar(j)*hgammar(k)
- hlagrange_gamma = hxir(i)*hetar(j)*hpgammar(k)
-
- eps_m_l_s(1) = eps_m_l_s(1) + eps_m_array(i,j,k) * (hlagrange_xi * xix_s &
- + hlagrange_eta * etax_s + hlagrange_gamma * gammax_s)
- eps_m_l_s(2) = eps_m_l_s(2) + eps_m_array(i,j,k) * (hlagrange_xi * xiy_s &
- + hlagrange_eta * etay_s + hlagrange_gamma * gammay_s)
- eps_m_l_s(3) = eps_m_l_s(3) + eps_m_array(i,j,k) * (hlagrange_xi * xiz_s &
- + hlagrange_eta * etaz_s + hlagrange_gamma * gammaz_s)
-
- enddo
- enddo
- enddo
-
-end subroutine compute_adj_source_frechet
-
-!================================================================
-!
-! deprecated...
-!
-!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
-!
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_boundary_kernel.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_boundary_kernel.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_boundary_kernel.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-subroutine compute_boundary_kernel(displ,accel,b_displ,nspec,iregion_code, &
- ystore,zstore,ibool,idoubling, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_yy,hprime_zz, &
- rhostore,kappavstore,muvstore,kappahstore,muhstore,eta_anisostore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- k_disc,ibelm_disc,normal_disc,b_kl,fluid_solid_boundary,NSPEC2D_DISC)
-
- implicit none
-
- include 'constants.h'
-
- real(kind=CUSTOM_REAL), dimension(NDIM,*) :: displ,accel,b_displ
- integer nspec, iregion_code
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer, dimension(*) :: idoubling
- real(kind=CUSTOM_REAL), dimension(*) :: ystore,zstore
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: rhostore, kappavstore,muvstore
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: kappahstore,muhstore,eta_anisostore
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store, c34store,c35store,c36store, &
- c44store,c45store,c46store,c55store,c56store,c66store
-
- integer NSPEC2D_DISC, k_disc
- integer :: ibelm_disc(NSPEC2D_DISC)
- real(kind=CUSTOM_REAL) :: normal_disc(NDIM,NGLLX,NGLLY,NSPEC2D_DISC)
- real(kind=CUSTOM_REAL) :: b_kl(NGLLX,NGLLY,NSPEC2D_DISC)
- logical :: fluid_solid_boundary
-
-! --- local variables ---
- integer ispec2D,i,j,k,iglob,ispec
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: displl, accell, b_displl, Kdvect
- real(kind=CUSTOM_REAL), dimension(NDIM) :: normal, temp1, temp2, temp3
- real(kind=CUSTOM_REAL) :: xixl, xiyl, xizl, etaxl, etayl, etazl, gammaxl, gammayl, gammazl
- real(kind=CUSTOM_REAL), dimension(NDIM,NDIM,NGLLX,NGLLY,NGLLZ) :: dsdx, sigma, b_dsdx, b_sigma
- real(kind=CUSTOM_REAL) :: b_kl_2(NGLLX,NGLLY)
- real(kind=CUSTOM_REAL) :: dKdx(NDIM,NDIM)
-
- ! ------
-
- ! initialization
- b_kl = 0.
-
- do ispec2D = 1, NSPEC2D_DISC
-
- ! assign local matrices
- ispec = ibelm_disc(ispec2D)
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool(i,j,k,ispec)
- displl(:,i,j,k) = displ(:,iglob)
- accell(:,i,j,k) = accel(:,iglob)
- b_displl(:,i,j,k) = b_displ(:,iglob)
- enddo
- enddo
- enddo
-
- ! strain and stress
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- normal(:) = normal_disc(:,i,j,ispec2D)
- 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)
-
- ! ----- adjoint strain ------
- temp1(:) = matmul(displl(:,:,j,k), hprime_xx(i,:))
- temp2(:) = matmul(displl(:,i,:,k), hprime_yy(j,:))
- temp3(:) = matmul(displl(:,i,j,:), hprime_zz(k,:))
-
- dsdx(1,1,i,j,k) = xixl*temp1(1) + etaxl*temp2(1) + gammaxl*temp3(1)
- dsdx(1,2,i,j,k) = xiyl*temp1(1) + etayl*temp2(1) + gammayl*temp3(1)
- dsdx(1,3,i,j,k) = xizl*temp1(1) + etazl*temp2(1) + gammazl*temp3(1)
-
- dsdx(2,1,i,j,k) = xixl*temp1(2) + etaxl*temp2(2) + gammaxl*temp3(2)
- dsdx(2,2,i,j,k) = xiyl*temp1(2) + etayl*temp2(2) + gammayl*temp3(2)
- dsdx(2,3,i,j,k) = xizl*temp1(2) + etazl*temp2(2) + gammazl*temp3(2)
-
- dsdx(3,1,i,j,k) = xixl*temp1(3) + etaxl*temp2(3) + gammaxl*temp3(3)
- dsdx(3,2,i,j,k) = xiyl*temp1(3) + etayl*temp2(3) + gammayl*temp3(3)
- dsdx(3,3,i,j,k) = xizl*temp1(3) + etazl*temp2(3) + gammazl*temp3(3)
-
- ! ------ adjoint stress -------
- call compute_stress_from_strain(dsdx(:,:,i,j,k),sigma(:,:,i,j,k),i,j,k,ispec,iregion_code, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ystore,zstore,ibool,idoubling)
-
- ! ----- forward strain -------
- temp1(:) = matmul(b_displl(:,:,j,k), hprime_xx(i,:))
- temp2(:) = matmul(b_displl(:,i,:,k), hprime_yy(j,:))
- temp3(:) = matmul(b_displl(:,i,j,:), hprime_zz(k,:))
-
- b_dsdx(1,1,i,j,k) = xixl*temp1(1) + etaxl*temp2(1) + gammaxl*temp3(1)
- b_dsdx(1,2,i,j,k) = xiyl*temp1(1) + etayl*temp2(1) + gammayl*temp3(1)
- b_dsdx(1,3,i,j,k) = xizl*temp1(1) + etazl*temp2(1) + gammazl*temp3(1)
-
- b_dsdx(2,1,i,j,k) = xixl*temp1(2) + etaxl*temp2(2) + gammaxl*temp3(2)
- b_dsdx(2,2,i,j,k) = xiyl*temp1(2) + etayl*temp2(2) + gammayl*temp3(2)
- b_dsdx(2,3,i,j,k) = xizl*temp1(2) + etazl*temp2(2) + gammazl*temp3(2)
-
- b_dsdx(3,1,i,j,k) = xixl*temp1(3) + etaxl*temp2(3) + gammaxl*temp3(3)
- b_dsdx(3,2,i,j,k) = xiyl*temp1(3) + etayl*temp2(3) + gammayl*temp3(3)
- b_dsdx(3,3,i,j,k) = xizl*temp1(3) + etazl*temp2(3) + gammazl*temp3(3)
-
- ! ----- forward stress ---------
- call compute_stress_from_strain(b_dsdx(:,:,i,j,k),b_sigma(:,:,i,j,k),i,j,k,ispec,iregion_code, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ystore,zstore,ibool,idoubling)
-
- ! ---- precompute K_d for F-S boundaries ----
- if (fluid_solid_boundary) then
- Kdvect(:,i,j,k) = dot_product( normal(:), matmul(sigma(:,:,i,j,k),normal(:)) ) * b_displl(:,i,j,k) &
- + dot_product( normal(:), matmul(b_sigma(:,:,i,j,k),normal(:)) ) * displl(:,i,j,k)
- ! important: take only the surface part of the Kdvect
- Kdvect(:,i,j,k) = Kdvect(:,i,j,k) - normal(:) * dot_product(Kdvect(:,i,j,k),normal(:))
- endif
-
-
- ! ----- kernel contributions from all boundaries (S-S and F-S)-----
- if (k == k_disc) then
- b_kl(i,j,ispec2D) = rhostore(i,j,k,ispec) * dot_product(b_displl(:,i,j,k),accell(:,i,j,k)) &
- + dot_product(b_dsdx(1,:,i,j,k),sigma(1,:,i,j,k)) &
- + dot_product(b_dsdx(2,:,i,j,k),sigma(2,:,i,j,k)) &
- + dot_product(b_dsdx(3,:,i,j,k),sigma(3,:,i,j,k)) &
- - dot_product( matmul(b_dsdx(:,:,i,j,k), normal(:)), matmul(sigma(:,:,i,j,k),normal(:)) ) &
- - dot_product( matmul(dsdx(:,:,i,j,k), normal(:)), matmul(b_sigma(:,:,i,j,k),normal(:)) )
- endif
-
- enddo
- enddo
- enddo
-
- ! ---- compute surface gradient of K_h for the surface element ----
- if (fluid_solid_boundary) then
-
- k = k_disc
- do j = 1, NGLLY
- do i = 1, NGLLX
-
- normal(:) = normal_disc(:,i,j,ispec2D)
-
- 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)
-
- ! ----- gradient of vector boundary kernel K_h------
- temp1(:) = matmul(Kdvect(:,:,j,k), hprime_xx(i,:))
- temp2(:) = matmul(Kdvect(:,i,:,k), hprime_yy(j,:))
- temp3(:) = matmul(Kdvect(:,i,j,:), hprime_zz(k,:))
-
- dKdx(1,1) = xixl*temp1(1) + etaxl*temp2(1) + gammaxl*temp3(1)
- dKdx(1,2) = xiyl*temp1(1) + etayl*temp2(1) + gammayl*temp3(1)
- dKdx(1,3) = xizl*temp1(1) + etazl*temp2(1) + gammazl*temp3(1)
-
- dKdx(2,1) = xixl*temp1(2) + etaxl*temp2(2) + gammaxl*temp3(2)
- dKdx(2,2) = xiyl*temp1(2) + etayl*temp2(2) + gammayl*temp3(2)
- dKdx(2,3) = xizl*temp1(2) + etazl*temp2(2) + gammazl*temp3(2)
-
- dKdx(3,1) = xixl*temp1(3) + etaxl*temp2(3) + gammaxl*temp3(3)
- dKdx(3,2) = xiyl*temp1(3) + etayl*temp2(3) + gammayl*temp3(3)
- dKdx(3,3) = xizl*temp1(3) + etazl*temp2(3) + gammazl*temp3(3)
-
- ! ----- extra boundary kernel contribution for F-S ------
- b_kl_2(i,j) = dKdx(1,1) + dKdx(2,2) + dKdx(3,3) + &
- dot_product( normal(:),matmul(dKdx(:,:),normal(:)) )
- enddo
- enddo
-
- b_kl(:,:,ispec2D) = b_kl(:,:,ispec2D) - b_kl_2(:,:)
- endif
-
- enddo
-
- end subroutine compute_boundary_kernel
-
-
-! ==========================================================================================
-
-
-subroutine compute_stress_from_strain(dsdx,sigma,i,j,k,ispec,iregion_code, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ystore,zstore,ibool,idoubling)
-
-
- implicit none
-
- include 'constants.h'
- include 'OUTPUT_FILES/values_from_mesher.h'
-
- real(kind=CUSTOM_REAL) :: dsdx(NDIM,NDIM), sigma(NDIM,NDIM)
- integer i, j, k, ispec, iregion_code
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: kappavstore,muvstore, &
- kappahstore,muhstore,eta_anisostore
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store
- real(kind=CUSTOM_REAL), dimension(*) :: ystore,zstore
- integer, dimension(NGLLX,NGLLY,NGLLZ,*) :: ibool
- integer, dimension(*) :: idoubling
-
-! --- local variables ---
- 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) :: duxdxl,duydyl,duzdzl,duxdxl_plus_duydyl_plus_duzdzl
- 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) kappal,mul,kappavl,kappahl,muvl,muhl,lambdal,lambdalplus2mul
- 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
-
- integer :: iglob
-
-
- ! --- precompute sum ---
-
- duxdxl_plus_duydyl = dsdx(1,1) + dsdx(2,2)
- duxdxl_plus_duzdzl = dsdx(1,1) + dsdx(3,3)
- duydyl_plus_duzdzl = dsdx(2,2) + dsdx(3,3)
- duxdyl_plus_duydxl = dsdx(1,2) + dsdx(2,1)
- duzdxl_plus_duxdzl = dsdx(3,1) + dsdx(1,3)
- duzdyl_plus_duydzl = dsdx(3,2) + dsdx(2,3)
- duxdxl = dsdx(1,1)
- duydyl = dsdx(2,2)
- duzdzl = dsdx(3,3)
-
- ! ----------------- mantle-----------------------
-
- if (iregion_code == IREGION_CRUST_MANTLE) then
-
- if(ANISOTROPIC_3D_MANTLE_VAL) then
-
- c11 = c11store(i,j,k,ispec)
- c12 = c12store(i,j,k,ispec)
- c13 = c13store(i,j,k,ispec)
- c14 = c14store(i,j,k,ispec)
- c15 = c15store(i,j,k,ispec)
- c16 = c16store(i,j,k,ispec)
- c22 = c22store(i,j,k,ispec)
- c23 = c23store(i,j,k,ispec)
- c24 = c24store(i,j,k,ispec)
- c25 = c25store(i,j,k,ispec)
- c26 = c26store(i,j,k,ispec)
- c33 = c33store(i,j,k,ispec)
- c34 = c34store(i,j,k,ispec)
- c35 = c35store(i,j,k,ispec)
- c36 = c36store(i,j,k,ispec)
- c44 = c44store(i,j,k,ispec)
- c45 = c45store(i,j,k,ispec)
- c46 = c46store(i,j,k,ispec)
- c55 = c55store(i,j,k,ispec)
- c56 = c56store(i,j,k,ispec)
- c66 = c66store(i,j,k,ispec)
-
- sigma(1,1) = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
- c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
-
- sigma(2,2) = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
- c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
-
- sigma(3,3) = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
- c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
-
- sigma(1,2) = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
- c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
-
- sigma(1,3) = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
- c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
-
- sigma(2,3) = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
- c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
-
- else if(.not. (TRANSVERSE_ISOTROPY_VAL .and. (idoubling(ispec) == IFLAG_80_MOHO .or. idoubling(ispec) == IFLAG_220_80))) then
-
- kappal = kappavstore(i,j,k,ispec)
- mul = muvstore(i,j,k,ispec)
-
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
-
- sigma(1,1) = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma(2,2) = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma(3,3) = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
-
- sigma(1,2) = mul*duxdyl_plus_duydxl
- sigma(1,3) = mul*duzdxl_plus_duxdzl
- sigma(2,3) = mul*duzdyl_plus_duydzl
-
- else
-
- kappavl = kappavstore(i,j,k,ispec)
- muvl = muvstore(i,j,k,ispec)
-
- kappahl = kappahstore(i,j,k,ispec)
- muhl = muhstore(i,j,k,ispec)
-
- 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(1,1) = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
- c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
-
- sigma(2,2) = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
- c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
-
- sigma(3,3) = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
- c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
-
- sigma(1,2) = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
- c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
-
- sigma(1,3) = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
- c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
-
- sigma(2,3) = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
- c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
-
- endif ! end of test whether isotropic or anisotropic element for the mantle
-
-! ------------------- outer core --------------------------
-
- else if (iregion_code == IREGION_OUTER_CORE) then
-
- kappal = kappavstore(i,j,k,ispec)
- duxdxl_plus_duydyl_plus_duzdzl = duxdxl+duydyl_plus_duzdzl
-
- sigma(1,1) = kappal * duxdxl_plus_duydyl_plus_duzdzl
- sigma(2,2) = sigma(1,1)
- sigma(3,3) = sigma(1,1)
-
- sigma(1,2) = 0
- sigma(1,3) = 0
- sigma(2,3) = 0
-
-! ------------------ inner core -------------------------
-
- else if (iregion_code == IREGION_INNER_CORE) then
-
- if(ANISOTROPIC_INNER_CORE_VAL) then
-
-! elastic tensor for hexagonal symmetry in reduced notation:
-!
-! c11 c12 c13 0 0 0
-! c12 c11 c13 0 0 0
-! c13 c13 c33 0 0 0
-! 0 0 0 c44 0 0
-! 0 0 0 0 c44 0
-! 0 0 0 0 0 (c11-c12)/2
-!
-! in terms of the A, C, L, N and F of Love (1927):
-!
-! c11 = A
-! c12 = A-2N
-! c13 = F
-! c33 = C
-! c44 = L
-! notice this is already in global coordinates
-
- c11 = c11store(i,j,k,ispec)
- c12 = c12store(i,j,k,ispec)
- c13 = c13store(i,j,k,ispec)
- c33 = c33store(i,j,k,ispec)
- c44 = c44store(i,j,k,ispec)
-
- sigma(1,1) = c11*duxdxl + c12*duydyl + c13*duzdzl
- sigma(2,2) = c12*duxdxl + c11*duydyl + c13*duzdzl
- sigma(3,3) = c13*duxdxl + c13*duydyl + c33*duzdzl
- sigma(1,2) = 0.5*(c11-c12)*duxdyl_plus_duydxl
- sigma(1,3) = c44*duzdxl_plus_duxdzl
- sigma(2,3) = c44*duzdyl_plus_duydzl
- else
-
-! inner core with no anisotropy, use kappav and muv for instance
-! layer with no anisotropy, use kappav and muv for instance
- kappal = kappavstore(i,j,k,ispec)
- mul = muvstore(i,j,k,ispec)
-
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
-
-! compute stress sigma
-
- sigma(1,1) = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma(2,2) = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma(3,3) = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
-
- sigma(1,2) = mul*duxdyl_plus_duydxl
- sigma(1,3) = mul*duzdxl_plus_duxdzl
- sigma(2,3) = mul*duzdyl_plus_duydzl
-
- endif
-
- endif
-
-! define symmetric components of sigma for gravity
- sigma(2,1) = sigma(1,2)
- sigma(3,1) = sigma(1,3)
- sigma(3,2) = sigma(2,3)
-
-
-
-end subroutine compute_stress_from_strain
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coordinates_grid.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coordinates_grid.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coordinates_grid.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_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/compute_coupling.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coupling.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coupling.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,535 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_coupling_fluid_CMB(displ_crust_mantle,b_displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- SIMULATION_TYPE,nspec_top)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_displ_crust_mantle
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
- integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
-
- integer SIMULATION_TYPE
- integer nspec_top
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n,nx,ny,nz,weight
- integer :: i,j,k,k_corresp,ispec,ispec2D,iglob_cm,iglob_oc,ispec_selected
-
-
- ! for surface elements exactly on the CMB
- do ispec2D = 1,nspec_top !NSPEC2D_TOP(IREGION_OUTER_CORE)
- ispec = ibelm_top_outer_core(ispec2D)
-
- ! only for DOFs exactly on the CMB (top of these elements)
- k = NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- ! get displacement on the solid side using pointwise matching
- ispec_selected = ibelm_bottom_crust_mantle(ispec2D)
-
- ! corresponding points are located at the bottom of the mantle
- k_corresp = 1
- iglob_cm = ibool_crust_mantle(i,j,k_corresp,ispec_selected)
-
- displ_x = displ_crust_mantle(1,iglob_cm)
- displ_y = displ_crust_mantle(2,iglob_cm)
- displ_z = displ_crust_mantle(3,iglob_cm)
-
- ! 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)
-
- ! get global point number
- iglob_oc = ibool_outer_core(i,j,k,ispec)
-
- ! update fluid acceleration/pressure
- accel_outer_core(iglob_oc) = accel_outer_core(iglob_oc) + weight*displ_n
-
- if (SIMULATION_TYPE == 3) then
- ! get displacement in crust mantle
- iglob_cm = ibool_crust_mantle(i,j,k_corresp,ispec_selected)
- displ_x = b_displ_crust_mantle(1,iglob_cm)
- displ_y = b_displ_crust_mantle(2,iglob_cm)
- displ_z = b_displ_crust_mantle(3,iglob_cm)
-
- displ_n = displ_x*nx + displ_y*ny + displ_z*nz
-
- ! update fluid acceleration/pressure
- iglob_oc = ibool_outer_core(i,j,k,ispec)
- b_accel_outer_core(iglob_oc) = b_accel_outer_core(iglob_oc) + weight*displ_n
- endif
-
- enddo
- enddo
- enddo
-
- end subroutine compute_coupling_fluid_CMB
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine compute_coupling_fluid_ICB(displ_inner_core,b_displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- SIMULATION_TYPE,nspec_bottom)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
- displ_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
- b_displ_inner_core
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
- integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
- integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
-
- integer SIMULATION_TYPE
- integer nspec_bottom
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n,nx,ny,nz,weight
- integer :: i,j,k,k_corresp,ispec,ispec2D,iglob_oc,iglob_ic,ispec_selected
-
-
- ! for surface elements exactly on the ICB
- do ispec2D = 1, nspec_bottom ! 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 displacement on the solid side using pointwise matching
- ispec_selected = ibelm_top_inner_core(ispec2D)
-
- ! corresponding points are located at the bottom of the mantle
- k_corresp = NGLLZ
- iglob_ic = ibool_inner_core(i,j,k_corresp,ispec_selected)
-
- displ_x = displ_inner_core(1,iglob_ic)
- displ_y = displ_inner_core(2,iglob_ic)
- displ_z = displ_inner_core(3,iglob_ic)
-
- ! 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)
-
- ! get global point number
- iglob_oc = ibool_outer_core(i,j,k,ispec)
-
- ! update fluid acceleration/pressure
- accel_outer_core(iglob_oc) = accel_outer_core(iglob_oc) - weight*displ_n
-
- if (SIMULATION_TYPE == 3) then
- ! get displacement in inner core
- iglob_ic = ibool_inner_core(i,j,k_corresp,ispec_selected)
- displ_x = b_displ_inner_core(1,iglob_ic)
- displ_y = b_displ_inner_core(2,iglob_ic)
- displ_z = b_displ_inner_core(3,iglob_ic)
-
- displ_n = displ_x*nx + displ_y*ny + displ_z*nz
-
-
- ! update fluid acceleration/pressure
- iglob_oc = ibool_outer_core(i,j,k,ispec)
- b_accel_outer_core(iglob_oc) = b_accel_outer_core(iglob_oc) - weight*displ_n
-
- endif
-
- enddo
- enddo
- enddo
-
- end subroutine compute_coupling_fluid_ICB
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine compute_coupling_CMB_fluid(displ_crust_mantle,b_displ_crust_mantle, &
- accel_crust_mantle,b_accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- RHO_TOP_OC,minus_g_cmb, &
- SIMULATION_TYPE,nspec_bottom)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- displ_crust_mantle,accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_displ_crust_mantle,b_accel_crust_mantle
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
- integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
-
- double precision RHO_TOP_OC
- real(kind=CUSTOM_REAL) minus_g_cmb
-
- integer SIMULATION_TYPE
- integer nspec_bottom
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: pressure,nx,ny,nz,weight
- integer :: i,j,k,k_corresp,ispec,ispec2D,iglob_oc,iglob_mantle,ispec_selected
-
-
- ! for surface elements exactly on the CMB
- do ispec2D = 1,nspec_bottom ! 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_oc = ibool_outer_core(i,j,NGLLZ,ispec_selected)
- iglob_mantle = ibool_crust_mantle(i,j,k,ispec)
-
- ! compute pressure, taking gravity into account
- if(GRAVITY_VAL) then
- pressure = RHO_TOP_OC * (- accel_outer_core(iglob_oc) &
- + minus_g_cmb *(displ_crust_mantle(1,iglob_mantle)*nx &
- + displ_crust_mantle(2,iglob_mantle)*ny + displ_crust_mantle(3,iglob_mantle)*nz))
- else
- pressure = - RHO_TOP_OC * accel_outer_core(iglob_oc)
- endif
-
- ! 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
-
- if (SIMULATION_TYPE == 3) then
- if(GRAVITY_VAL) then
- pressure = RHO_TOP_OC * (- b_accel_outer_core(iglob_oc) &
- + minus_g_cmb *(b_displ_crust_mantle(1,iglob_mantle)*nx &
- + b_displ_crust_mantle(2,iglob_mantle)*ny + b_displ_crust_mantle(3,iglob_mantle)*nz))
- else
- pressure = - RHO_TOP_OC * b_accel_outer_core(iglob_oc)
- endif
- b_accel_crust_mantle(1,iglob_mantle) = b_accel_crust_mantle(1,iglob_mantle) + weight*nx*pressure
- b_accel_crust_mantle(2,iglob_mantle) = b_accel_crust_mantle(2,iglob_mantle) + weight*ny*pressure
- b_accel_crust_mantle(3,iglob_mantle) = b_accel_crust_mantle(3,iglob_mantle) + weight*nz*pressure
- endif
-
- enddo
- enddo
- enddo
-
- end subroutine compute_coupling_CMB_fluid
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine compute_coupling_ICB_fluid(displ_inner_core,b_displ_inner_core, &
- accel_inner_core,b_accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- RHO_BOTTOM_OC,minus_g_icb, &
- SIMULATION_TYPE,nspec_top)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
- displ_inner_core,accel_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
- b_displ_inner_core,b_accel_inner_core
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
- integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
- integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
-
- double precision RHO_BOTTOM_OC
- real(kind=CUSTOM_REAL) minus_g_icb
-
- integer SIMULATION_TYPE
- integer nspec_top
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: pressure,nx,ny,nz,weight
- integer :: i,j,k,k_corresp,ispec,ispec2D,iglob,iglob_inner_core,ispec_selected
-
- ! for surface elements exactly on the ICB
- do ispec2D = 1,nspec_top ! 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
- if(GRAVITY_VAL) then
- pressure = RHO_BOTTOM_OC * (- accel_outer_core(iglob) &
- + minus_g_icb *(displ_inner_core(1,iglob_inner_core)*nx &
- + displ_inner_core(2,iglob_inner_core)*ny + displ_inner_core(3,iglob_inner_core)*nz))
- else
- pressure = - RHO_BOTTOM_OC * accel_outer_core(iglob)
- endif
-
- ! 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
-
- if (SIMULATION_TYPE == 3) then
- if(GRAVITY_VAL) then
- pressure = RHO_BOTTOM_OC * (- b_accel_outer_core(iglob) &
- + minus_g_icb *(b_displ_inner_core(1,iglob_inner_core)*nx &
- + b_displ_inner_core(2,iglob_inner_core)*ny + b_displ_inner_core(3,iglob_inner_core)*nz))
- else
- pressure = - RHO_BOTTOM_OC * b_accel_outer_core(iglob)
- endif
- b_accel_inner_core(1,iglob_inner_core) = b_accel_inner_core(1,iglob_inner_core) - weight*nx*pressure
- b_accel_inner_core(2,iglob_inner_core) = b_accel_inner_core(2,iglob_inner_core) - weight*ny*pressure
- b_accel_inner_core(3,iglob_inner_core) = b_accel_inner_core(3,iglob_inner_core) - weight*nz*pressure
- endif
-
- enddo
- enddo
- enddo
-
- end subroutine compute_coupling_ICB_fluid
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine compute_coupling_ocean(accel_crust_mantle,b_accel_crust_mantle, &
- rmass_crust_mantle,rmass_ocean_load,normal_top_crust_mantle, &
- ibool_crust_mantle,ibelm_top_crust_mantle, &
- updated_dof_ocean_load, &
- SIMULATION_TYPE,nspec_top)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_accel_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
-
- logical, dimension(NGLOB_CRUST_MANTLE_OCEANS) :: updated_dof_ocean_load
-
- integer SIMULATION_TYPE
- integer nspec_top
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: force_normal_comp,b_force_normal_comp
- real(kind=CUSTOM_REAL) :: additional_term,b_additional_term
- real(kind=CUSTOM_REAL) :: nx,ny,nz
- integer :: i,j,k,ispec,ispec2D,iglob
-
- ! initialize the updates
- updated_dof_ocean_load(:) = .false.
-
- ! for surface elements exactly at the top of the crust (ocean bottom)
- do ispec2D = 1,nspec_top !NSPEC2D_TOP(IREGION_CRUST_MANTLE)
-
- ispec = ibelm_top_crust_mantle(ispec2D)
-
- ! only for DOFs exactly at the top of the crust (ocean bottom)
- k = NGLLZ
-
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- ! get global point number
- iglob = ibool_crust_mantle(i,j,k,ispec)
-
- ! only update once
- if(.not. updated_dof_ocean_load(iglob)) then
-
- ! get normal
- nx = normal_top_crust_mantle(1,i,j,ispec2D)
- ny = normal_top_crust_mantle(2,i,j,ispec2D)
- nz = normal_top_crust_mantle(3,i,j,ispec2D)
-
- ! make updated component of right-hand side
- ! we divide by rmass_crust_mantle() which is 1 / M
- ! we use the total force which includes the Coriolis term above
- force_normal_comp = (accel_crust_mantle(1,iglob)*nx + &
- accel_crust_mantle(2,iglob)*ny + &
- accel_crust_mantle(3,iglob)*nz) / rmass_crust_mantle(iglob)
-
- additional_term = (rmass_ocean_load(iglob) - rmass_crust_mantle(iglob)) * force_normal_comp
-
- accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + additional_term * nx
- accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + additional_term * ny
- accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + additional_term * nz
-
- if (SIMULATION_TYPE == 3) then
- b_force_normal_comp = (b_accel_crust_mantle(1,iglob)*nx + &
- b_accel_crust_mantle(2,iglob)*ny + &
- b_accel_crust_mantle(3,iglob)*nz) / rmass_crust_mantle(iglob)
-
- b_additional_term = (rmass_ocean_load(iglob) - rmass_crust_mantle(iglob)) * b_force_normal_comp
-
- b_accel_crust_mantle(1,iglob) = b_accel_crust_mantle(1,iglob) + b_additional_term * nx
- b_accel_crust_mantle(2,iglob) = b_accel_crust_mantle(2,iglob) + b_additional_term * ny
- b_accel_crust_mantle(3,iglob) = b_accel_crust_mantle(3,iglob) + b_additional_term * nz
- endif
-
- ! done with this point
- updated_dof_ocean_load(iglob) = .true.
-
- endif
-
- enddo
- enddo
- enddo
-
- end subroutine compute_coupling_ocean
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_element_properties.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_element_properties.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_element_properties.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,297 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! compute several rheological and geometrical properties for a given spectral element
- subroutine compute_element_properties(ispec,iregion_code,idoubling, &
- xstore,ystore,zstore,nspec,myrank,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore,nspec_actually, &
- 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
- rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
- xigll,yigll,zigll)
-
- use meshfem3D_models_par
-
- implicit none
-
- !include "constants.h"
-
-! correct number of spectral elements in each block depending on chunk type
- integer ispec,nspec,nspec_stacey
-
- logical ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS
-
- double precision RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,&
- R400,R120,R80,RMIDDLE_CRUST,ROCEAN,RMOHO_FICTITIOUS_IN_MESHER
-
-! 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(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
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,dvpstore,kappavstore, &
- kappahstore,muvstore,muhstore,eta_anisostore
-
-! the 21 coefficients for an anisotropic medium in reduced notation
- integer nspec_ani
- 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
-
-! arrays with mesh parameters
- integer nspec_actually
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
- 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
- integer nspec_att
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
- double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
- double precision, dimension(N_SLS) :: tau_s
- double precision T_c_source
-
- ! Parameters used to calculate Jacobian based upon 125 GLL points
- double precision:: xigll(NGLLX)
- double precision:: yigll(NGLLY)
- double precision:: zigll(NGLLZ)
-
- ! Parameter used to decide whether this element is in the crust or not
- logical:: elem_in_crust,elem_in_mantle
-
- ! add topography of the Moho *before* adding the 3D crustal velocity model so that the streched
- ! mesh gets assigned the right model values
- elem_in_crust = .false.
- elem_in_mantle = .false.
- if( iregion_code == IREGION_CRUST_MANTLE ) then
- if( CRUSTAL .and. CASE_3D ) then
- if( idoubling(ispec) == IFLAG_CRUST &
- .or. idoubling(ispec) == IFLAG_220_80 &
- .or. idoubling(ispec) == IFLAG_80_MOHO ) then
- ! Stretch mesh to honor smoothed moho thickness from crust2.0
-
- ! differentiate between regional and global meshing
- if( REGIONAL_MOHO_MESH ) then
- call moho_stretching_honor_crust_reg(myrank, &
- xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
- else
- call moho_stretching_honor_crust(myrank, &
- xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
- endif
- endif
- endif
- endif
-
- ! interpolates and stores GLL point locations
- call compute_element_GLL_locations(xelm,yelm,zelm,ispec,nspec, &
- xstore,ystore,zstore,shape3D)
-
-
- ! computes model's velocity/density/... values for the chosen Earth model
- call get_model(myrank,iregion_code,ispec,nspec,idoubling(ispec), &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- rhostore,dvpstore,nspec_ani, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- nspec_stacey,rho_vp,rho_vs, &
- xstore,ystore,zstore, &
- rmin,rmax,RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220, &
- R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- 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,elem_in_crust,elem_in_mantle)
-
-
- ! either use GLL points or anchor points to capture TOPOGRAPHY and ELLIPTICITY
- ! note: using gll points to capture them results in a slightly more accurate mesh.
- ! however, it introduces more deformations to the elements which might lead to
- ! problems with the jacobian. using the anchors is therefore more robust.
- ! adds surface topography
- if( TOPOGRAPHY ) then
- if (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
- .or. idoubling(ispec)==IFLAG_80_MOHO) then
- ! stretches mesh between surface and R220 accordingly
- if( USE_GLL ) then
- ! stretches every gll point accordingly
- call add_topography_gll(myrank,xstore,ystore,zstore,ispec,nspec,ibathy_topo,R220)
- else
- ! stretches anchor points only, interpolates gll points later on
- call add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
- endif
- endif
- endif
-
- ! adds 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) then
- if( USE_GLL ) then
- ! stretches every gll point accordingly
- call add_topography_410_650_gll(myrank,xstore,ystore,zstore,ispec,nspec,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)
-
- else
- ! stretches anchor points only, interpolates gll points later on
- 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)
- endif
- endif
-
- ! these are placeholders:
- ! their corresponding subroutines subtopo_cmb() and subtopo_icb() are not implemented yet....
- ! must be done/supplied by the user; uncomment in case
- ! CMB topography
- ! 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
- ! 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) then
- if( USE_GLL ) then
- ! make the Earth's ellipticity, use GLL points
- call get_ellipticity_gll(xstore,ystore,zstore,ispec,nspec,nspl,rspl,espl,espl2)
- else
- ! make the Earth's ellipticity, use element anchor points
- call get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2)
- endif
- endif
-
- ! re-interpolates and creates the GLL point locations since the anchor points might have moved
- !
- ! note: velocity values associated for each GLL point will "move" along together with
- ! their associated points. however, we don't re-calculate the velocity model values since the
- ! models are/should be referenced with respect to a spherical Earth.
- if( .not. USE_GLL) &
- call compute_element_GLL_locations(xelm,yelm,zelm,ispec,nspec, &
- xstore,ystore,zstore,shape3D)
-
- ! updates jacobian
- call recalc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
- ispec,nspec,ACTUALLY_STORE_ARRAYS,&
- xixstore,xiystore,xizstore,&
- etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore)
-
- end subroutine compute_element_properties
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine compute_element_GLL_locations(xelm,yelm,zelm,ispec,nspec, &
- xstore,ystore,zstore,shape3D)
-
- implicit none
-
- include "constants.h"
-
- integer ispec,nspec
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
-
- ! local parameters
- double precision xmesh,ymesh,zmesh
- integer i,j,k,ia
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- xmesh = ZERO
- ymesh = ZERO
- zmesh = ZERO
-
- ! interpolates the location using 3D shape functions
- 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
-
- ! stores 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 compute_element_GLL_locations
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,955 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle,xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
-!----------------------
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_INNER_CORE,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ibool,idoubling,R_memory,epsilondev,epsilon_trace_over_3,one_minus_sum_beta, &
- alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec)
-
- 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"
-
-! model_attenuation_variables
-! type model_attenuation_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
-! 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, dimension(:), pointer :: interval_Q ! Steps
-! integer :: Qn ! Number of points
-! integer dummy_pad ! padding 4 bytes to align the structure
-! end type model_attenuation_variables
-
-! 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_crust_mantle,accel_crust_mantle
-
-! 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
-
-! 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(NGLLX, NGLLY, NGLLZ) :: factor_common_c44_muv
-
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilon_trace_over_3
-
-! 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
-
-! arrays for full anisotropy only when needed
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store
-
- integer ispec,iglob,ispec_strain
- 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
- integer int_radius
- real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
- double precision radius,rho,minus_g,minus_dg
- double precision minus_g_over_radius,minus_dg_plus_g_over_radius
- double precision cos_theta,sin_theta,cos_phi,sin_phi
- double precision cos_theta_sq,sin_theta_sq,cos_phi_sq,sin_phi_sq
- double precision factor,sx_l,sy_l,sz_l,gxl,gyl,gzl
- double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
- double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
-
-! this for non blocking MPI
- integer :: iphase,icall
-
- integer :: computed_elements
-
- logical, dimension(NSPEC_CRUST_MANTLE) :: is_on_a_slice_edge_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: accel_inner_core
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
-
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
-
- integer :: ichunk,iproc_xi,iproc_eta,myrank
-
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
-
- 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
-
- integer npoin2D_faces_crust_mantle(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_inner_core,npoin2D_eta_inner_core
-
-! 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(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
- integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
-
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
-
- integer :: npoin2D_max_all_CM_IC
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
-
-! 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_chunkcorn_vector,buffer_recv_chunkcorn_vector
-
-! for matching with central cube in inner core
- integer nb_msgs_theor_in_cube, npoin2D_cube_from_slices,iphase_CC
- integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
- double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices
- double precision, dimension(npoin2D_cube_from_slices,NDIM,nb_msgs_theor_in_cube) :: buffer_all_cube_from_slices
- integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
- integer receiver_cube_from_slices
- logical :: INCLUDE_CENTRAL_CUBE
-
-! local to global mapping
- integer NSPEC2D_BOTTOM_INNER_CORE
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
-
-! ****************************************************
-! big loop over all spectral elements in the solid
-! ****************************************************
-
- computed_elements = 0
-
- do ispec = 1,NSPEC_CRUST_MANTLE
-
-! hide communications by computing the edges first
- if((icall == 2 .and. is_on_a_slice_edge_crust_mantle(ispec)) .or. &
- (icall == 1 .and. .not. is_on_a_slice_edge_crust_mantle(ispec))) cycle
-
-! process the communications every ELEMENTS_NONBLOCKING elements
- computed_elements = computed_elements + 1
- if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_CM_IC) == 0) then
-
- if(iphase <= 7) call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_CM, &
- NGLOB1D_RADIAL_IC,NCHUNKS_VAL,iphase)
-
- if(INCLUDE_CENTRAL_CUBE) then
- if(iphase > 7 .and. iphase_CC <= 4) &
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,accel_inner_core,NDIM,iphase_CC)
- endif
-
- endif
-
- 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_crust_mantle(1,iglob)*hp1
- tempy1l = tempy1l + displ_crust_mantle(2,iglob)*hp1
- tempz1l = tempz1l + displ_crust_mantle(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_crust_mantle(1,iglob)*hp2
- tempy2l = tempy2l + displ_crust_mantle(2,iglob)*hp2
- tempz2l = tempz2l + displ_crust_mantle(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_crust_mantle(1,iglob)*hp3
- tempy3l = tempy3l + displ_crust_mantle(2,iglob)*hp3
- tempz3l = tempz3l + displ_crust_mantle(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
- if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
- ispec_strain = 1
- else
- ispec_strain = ispec
- endif
- epsilon_trace_over_3(i,j,k,ispec_strain) = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(1,i,j,k) = duxdxl - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(2,i,j,k) = duydyl - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
- endif
-
- ! precompute terms for attenuation if needed
- if(ATTENUATION_VAL) then
- one_minus_sum_beta_use = one_minus_sum_beta(i,j,k,ispec)
- minus_sum_beta = one_minus_sum_beta_use - 1.0
- endif
-
- !
- ! compute either isotropic or anisotropic elements
- !
-
- if(ANISOTROPIC_3D_MANTLE_VAL) then
-
- c11 = c11store(i,j,k,ispec)
- c12 = c12store(i,j,k,ispec)
- c13 = c13store(i,j,k,ispec)
- c14 = c14store(i,j,k,ispec)
- c15 = c15store(i,j,k,ispec)
- c16 = c16store(i,j,k,ispec)
- c22 = c22store(i,j,k,ispec)
- c23 = c23store(i,j,k,ispec)
- c24 = c24store(i,j,k,ispec)
- c25 = c25store(i,j,k,ispec)
- c26 = c26store(i,j,k,ispec)
- c33 = c33store(i,j,k,ispec)
- c34 = c34store(i,j,k,ispec)
- c35 = c35store(i,j,k,ispec)
- c36 = c36store(i,j,k,ispec)
- c44 = c44store(i,j,k,ispec)
- c45 = c45store(i,j,k,ispec)
- c46 = c46store(i,j,k,ispec)
- c55 = c55store(i,j,k,ispec)
- c56 = c56store(i,j,k,ispec)
- c66 = c66store(i,j,k,ispec)
-
- if(ATTENUATION_VAL) then
- mul = c44
- c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
- c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
- c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
- c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
- c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
- c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
- c44 = c44 + minus_sum_beta * mul
- c55 = c55 + minus_sum_beta * mul
- c66 = c66 + minus_sum_beta * mul
- endif
-
- 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
-
- 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 .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) 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
-
- ! define symmetric components of sigma for gravity
- sigma_yx = sigma_xy
- sigma_zx = sigma_xz
- sigma_zy = sigma_yz
-
- ! compute non-symmetric terms for gravity
- if(GRAVITY_VAL) then
-
- ! use mesh coordinates to get theta and phi
- ! x y and z contain r theta and phi
-
- iglob = ibool(i,j,k,ispec)
- radius = dble(xstore(iglob))
- theta = ystore(iglob)
- phi = zstore(iglob)
-
- cos_theta = dcos(dble(theta))
- sin_theta = dsin(dble(theta))
- cos_phi = dcos(dble(phi))
- sin_phi = dsin(dble(phi))
-
- ! get g, rho and dg/dr=dg
- ! spherical components of the gravitational acceleration
- ! for efficiency replace with lookup table every 100 m in radial direction
- int_radius = nint(radius * R_EARTH_KM * 10.d0)
- minus_g = minus_gravity_table(int_radius)
- minus_dg = minus_deriv_gravity_table(int_radius)
- rho = density_table(int_radius)
-
- ! Cartesian components of the gravitational acceleration
- gxl = minus_g*sin_theta*cos_phi
- gyl = minus_g*sin_theta*sin_phi
- gzl = minus_g*cos_theta
-
- ! Cartesian components of gradient of gravitational acceleration
- ! obtained from spherical components
-
- minus_g_over_radius = minus_g / radius
- minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
-
- cos_theta_sq = cos_theta**2
- sin_theta_sq = sin_theta**2
- cos_phi_sq = cos_phi**2
- sin_phi_sq = sin_phi**2
-
- Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
- Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
- Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
- Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
- Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
- Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
-
- iglob = ibool(i,j,k,ispec)
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
-
- ! get displacement and multiply by density to compute G tensor
- sx_l = rho * dble(displ_crust_mantle(1,iglob))
- sy_l = rho * dble(displ_crust_mantle(2,iglob))
- sz_l = rho * dble(displ_crust_mantle(3,iglob))
-
- ! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
- sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
- sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
-
- sigma_xy = sigma_xy - sngl(sx_l * gyl)
- sigma_yx = sigma_yx - sngl(sy_l * gxl)
-
- sigma_xz = sigma_xz - sngl(sx_l * gzl)
- sigma_zx = sigma_zx - sngl(sz_l * gxl)
-
- sigma_yz = sigma_yz - sngl(sy_l * gzl)
- sigma_zy = sigma_zy - sngl(sz_l * gyl)
-
- ! precompute vector
- factor = dble(jacobianl) * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
- rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
- rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
-
- else
-
- ! get displacement and multiply by density to compute G tensor
- sx_l = rho * displ_crust_mantle(1,iglob)
- sy_l = rho * displ_crust_mantle(2,iglob)
- sz_l = rho * displ_crust_mantle(3,iglob)
-
- ! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
- sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
- sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
-
- sigma_xy = sigma_xy - sx_l * gyl
- sigma_yx = sigma_yx - sy_l * gxl
-
- sigma_xz = sigma_xz - sx_l * gzl
- sigma_zx = sigma_zx - sz_l * gxl
-
- sigma_yz = sigma_yz - sy_l * gzl
- sigma_zy = sigma_zy - sz_l * gyl
-
- ! precompute vector
- factor = jacobianl * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
- rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
- rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
-
- endif
-
- endif ! end of section with gravity terms
-
- ! form dot product with test vector, non-symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
-
- enddo ! NGLLX
- enddo ! NGLLY
- enddo ! NGLLZ
-
- 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)
-
- if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
-
- enddo ! NGLLX
- enddo ! NGLLY
- enddo ! NGLLZ
-
-! sum contributions from each element to the global mesh and add gravity terms
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + sum_terms(1,i,j,k)
- accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + sum_terms(2,i,j,k)
- accel_crust_mantle(3,iglob) = accel_crust_mantle(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
-! This is because we only implement Q_\mu attenuation and not Q_\kappa.
-! Note that this does *NOT* imply that there is no attenuation for P waves
-! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
-! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
-! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
-! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
-
- if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. )) 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
-
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- factor_common_c44_muv = factor_common(i_SLS,:,:,:,ispec)
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- factor_common_c44_muv = factor_common_c44_muv * c44store(:,:,:,ispec)
- else
- factor_common_c44_muv = factor_common_c44_muv * muvstore(:,:,:,ispec)
- endif
-
- R_memory(i_memory,i_SLS,:,:,:,ispec) = alphaval(i_SLS) * &
- R_memory(i_memory,i_SLS,:,:,:,ispec) + &
- factor_common_c44_muv * &
- (betaval(i_SLS) * epsilondev(i_memory,:,:,:,ispec) + &
- gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
- enddo
- enddo
-
- endif
-
-! save deviatoric strain for Runge-Kutta scheme
- if(COMPUTE_AND_STORE_STRAIN) then
- !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- epsilondev(:,i,j,k,ispec) = epsilondev_loc(:,i,j,k)
- enddo
- enddo
- enddo
- endif
-
- enddo ! spectral element loop NSPEC_CRUST_MANTLE
-
- end subroutine compute_forces_crust_mantle
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle_Dev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle_Dev.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle_Dev.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1155 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle,xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
-!----------------------
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_INNER_CORE,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ibool,idoubling,R_memory,epsilondev,epsilon_trace_over_3,one_minus_sum_beta, &
- alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec)
-
-! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
-
- 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(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle,accel_crust_mantle
- ! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool
-
- ! 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,NSPEC_CRUST_MANTLE) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-
- ! array with derivatives of Lagrange polynomials and precalculated products
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
- ! store anisotropic properties only where needed to save memory
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
- kappahstore,muhstore,eta_anisostore
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
- kappavstore,muvstore
-
- ! arrays for full anisotropy only when needed
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store
-
- ! attenuation
- ! memory variables for attenuation
- ! memory variables R_ij are stored at the local rather than global level
- ! to allow for optimization of cache access by compiler
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilon_trace_over_3
-
- integer vx,vy,vz,vnspec
-
- ! [alpha,beta,gamma]val reduced to N_SLS and factor_common to N_SLS*NUM_NODES
- real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: factor_common
- real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
-
- ! array with the local to global mapping per slice
- integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling
-
- ! gravity
- double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
-
-! local parameters
- ! Deville
- ! manually inline the calls to the Deville et al. (2002) routines
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
- newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
- real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
- real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
- real(kind=CUSTOM_REAL), dimension(m1,m2) :: E1_m1_m2_5points,E2_m1_m2_5points,E3_m1_m2_5points
-
- equivalence(dummyx_loc,B1_m1_m2_5points)
- equivalence(dummyy_loc,B2_m1_m2_5points)
- equivalence(dummyz_loc,B3_m1_m2_5points)
- equivalence(tempx1,C1_m1_m2_5points)
- equivalence(tempy1,C2_m1_m2_5points)
- equivalence(tempz1,C3_m1_m2_5points)
- equivalence(newtempx1,E1_m1_m2_5points)
- equivalence(newtempy1,E2_m1_m2_5points)
- equivalence(newtempz1,E3_m1_m2_5points)
-
- real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: &
- A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
- real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
- C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
- real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
- E1_mxm_m2_m1_5points,E2_mxm_m2_m1_5points,E3_mxm_m2_m1_5points
-
- equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
- equivalence(dummyy_loc,A2_mxm_m2_m1_5points)
- equivalence(dummyz_loc,A3_mxm_m2_m1_5points)
- equivalence(tempx3,C1_mxm_m2_m1_5points)
- equivalence(tempy3,C2_mxm_m2_m1_5points)
- equivalence(tempz3,C3_mxm_m2_m1_5points)
- equivalence(newtempx3,E1_mxm_m2_m1_5points)
- equivalence(newtempy3,E2_mxm_m2_m1_5points)
- equivalence(newtempz3,E3_mxm_m2_m1_5points)
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
-
- ! for attenuation
- real(kind=CUSTOM_REAL), dimension(NGLLX, NGLLY, NGLLZ) :: &
- factor_common_c44_muv
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
- real(kind=CUSTOM_REAL) R_xx_val1,R_yy_val1,R_xx_val2,R_yy_val2,R_xx_val3,R_yy_val3
- real(kind=CUSTOM_REAL) one_minus_sum_beta_use,minus_sum_beta
-
- ! 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) fac1,fac2,fac3,templ
- real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
- real(kind=CUSTOM_REAL) kappal,kappavl,kappahl,muvl,muhl
-
- ! for gravity
- double precision radius,rho,minus_g,minus_dg
- double precision minus_g_over_radius,minus_dg_plus_g_over_radius
- double precision cos_theta,sin_theta,cos_phi,sin_phi
- double precision cos_theta_sq,sin_theta_sq,cos_phi_sq,sin_phi_sq
- double precision factor,sx_l,sy_l,sz_l,gxl,gyl,gzl
- double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
- real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
-
- integer :: i_SLS,i_memory,imodulo_N_SLS
- integer :: ispec,ispec_strain
- integer :: i,j,k
- integer :: int_radius
- integer :: iglob1,iglob2,iglob3,iglob4,iglob5
-
-! this for non blocking MPI
- integer :: iphase,icall
-
- integer :: computed_elements
-
- logical, dimension(NSPEC_CRUST_MANTLE) :: is_on_a_slice_edge_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: accel_inner_core
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
-
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
-
- integer :: ichunk,iproc_xi,iproc_eta,myrank
-
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
-
- 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
-
- integer npoin2D_faces_crust_mantle(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_inner_core,npoin2D_eta_inner_core
-
-! 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(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
- integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
-
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
-
- integer :: npoin2D_max_all_CM_IC
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
-
-! 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_chunkcorn_vector,buffer_recv_chunkcorn_vector
-
-! for matching with central cube in inner core
- integer nb_msgs_theor_in_cube, npoin2D_cube_from_slices,iphase_CC
- integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
- double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices
- double precision, dimension(npoin2D_cube_from_slices,NDIM,nb_msgs_theor_in_cube) :: buffer_all_cube_from_slices
- integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
- integer receiver_cube_from_slices
- logical :: INCLUDE_CENTRAL_CUBE
-
-! local to global mapping
- integer NSPEC2D_BOTTOM_INNER_CORE
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
-
-! ****************************************************
-! big loop over all spectral elements in the solid
-! ****************************************************
-
- imodulo_N_SLS = mod(N_SLS,3)
-
- computed_elements = 0
-
- do ispec = 1,NSPEC_CRUST_MANTLE
-
-! hide communications by computing the edges first
- if((icall == 2 .and. is_on_a_slice_edge_crust_mantle(ispec)) .or. &
- (icall == 1 .and. .not. is_on_a_slice_edge_crust_mantle(ispec))) cycle
-
-! process the communications every ELEMENTS_NONBLOCKING elements
- computed_elements = computed_elements + 1
- if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_CM_IC) == 0) then
-
- if(iphase <= 7) call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_CM, &
- NGLOB1D_RADIAL_IC,NCHUNKS_VAL,iphase)
-
- if(INCLUDE_CENTRAL_CUBE) then
- if(iphase > 7 .and. iphase_CC <= 4) &
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,accel_inner_core,NDIM,iphase_CC)
- endif
-
- endif
-
- ! subroutines adapted from Deville, Fischer and Mund, High-order methods
- ! for incompressible fluid flow, Cambridge University Press (2002),
- ! pages 386 and 389 and Figure 8.3.1
- do k=1,NGLLZ
- do j=1,NGLLY
-
-! way 1:
-! do i=1,NGLLX
-! iglob = ibool(i,j,k,ispec)
-! dummyx_loc(i,j,k) = displ_crust_mantle(1,iglob)
-! dummyy_loc(i,j,k) = displ_crust_mantle(2,iglob)
-! dummyz_loc(i,j,k) = displ_crust_mantle(3,iglob)
-! enddo
-
-! way 2:
- ! since we know that NGLLX = 5, this should help pipelining
- iglob1 = ibool(1,j,k,ispec)
- iglob2 = ibool(2,j,k,ispec)
- iglob3 = ibool(3,j,k,ispec)
- iglob4 = ibool(4,j,k,ispec)
- iglob5 = ibool(5,j,k,ispec)
-
- dummyx_loc(1,j,k) = displ_crust_mantle(1,iglob1)
- dummyy_loc(1,j,k) = displ_crust_mantle(2,iglob1)
- dummyz_loc(1,j,k) = displ_crust_mantle(3,iglob1)
-
- dummyx_loc(2,j,k) = displ_crust_mantle(1,iglob2)
- dummyy_loc(2,j,k) = displ_crust_mantle(2,iglob2)
- dummyz_loc(2,j,k) = displ_crust_mantle(3,iglob2)
-
- dummyx_loc(3,j,k) = displ_crust_mantle(1,iglob3)
- dummyy_loc(3,j,k) = displ_crust_mantle(2,iglob3)
- dummyz_loc(3,j,k) = displ_crust_mantle(3,iglob3)
-
- dummyx_loc(4,j,k) = displ_crust_mantle(1,iglob4)
- dummyy_loc(4,j,k) = displ_crust_mantle(2,iglob4)
- dummyz_loc(4,j,k) = displ_crust_mantle(3,iglob4)
-
- dummyx_loc(5,j,k) = displ_crust_mantle(1,iglob5)
- dummyy_loc(5,j,k) = displ_crust_mantle(2,iglob5)
- dummyz_loc(5,j,k) = displ_crust_mantle(3,iglob5)
-
- enddo
- enddo
- do j=1,m2
- do i=1,m1
- C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B1_m1_m2_5points(5,j)
-
- C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B2_m1_m2_5points(5,j)
-
- C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B3_m1_m2_5points(5,j)
- enddo
- enddo
- do j=1,m1
- do i=1,m1
- ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyx_loc(i,5,k)*hprime_xxT(5,j)
-
- tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyy_loc(i,5,k)*hprime_xxT(5,j)
-
- tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyz_loc(i,5,k)*hprime_xxT(5,j)
- enddo
- enddo
- enddo
- do j=1,m1
- do i=1,m2
- C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
-
- C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
-
- C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- ! get derivatives of ux, uy and uz with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
-
- ! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- duxdxl = xixl*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
- duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
- duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
-
- duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
- duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
- duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
-
- duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
- duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
- duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
-
- ! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
-
- ! compute deviatoric strain
- if (COMPUTE_AND_STORE_STRAIN) then
- if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
- ispec_strain = 1
- else
- ispec_strain = ispec
- endif
- templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilon_trace_over_3(i,j,k,ispec_strain) = templ
- epsilondev_loc(1,i,j,k) = duxdxl - templ
- epsilondev_loc(2,i,j,k) = duydyl - templ
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
- 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
- one_minus_sum_beta_use = one_minus_sum_beta(i,j,k,ispec)
- minus_sum_beta = one_minus_sum_beta_use - 1.0
- endif
-
- !
- ! compute either isotropic or anisotropic elements
- !
- if(ANISOTROPIC_3D_MANTLE_VAL) then
-
- c11 = c11store(i,j,k,ispec)
- c12 = c12store(i,j,k,ispec)
- c13 = c13store(i,j,k,ispec)
- c14 = c14store(i,j,k,ispec)
- c15 = c15store(i,j,k,ispec)
- c16 = c16store(i,j,k,ispec)
- c22 = c22store(i,j,k,ispec)
- c23 = c23store(i,j,k,ispec)
- c24 = c24store(i,j,k,ispec)
- c25 = c25store(i,j,k,ispec)
- c26 = c26store(i,j,k,ispec)
- c33 = c33store(i,j,k,ispec)
- c34 = c34store(i,j,k,ispec)
- c35 = c35store(i,j,k,ispec)
- c36 = c36store(i,j,k,ispec)
- c44 = c44store(i,j,k,ispec)
- c45 = c45store(i,j,k,ispec)
- c46 = c46store(i,j,k,ispec)
- c55 = c55store(i,j,k,ispec)
- c56 = c56store(i,j,k,ispec)
- c66 = c66store(i,j,k,ispec)
-
- if(ATTENUATION_VAL) then
- mul = c44
- c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
- c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
- c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
- c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
- c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
- c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
- c44 = c44 + minus_sum_beta * mul
- c55 = c55 + minus_sum_beta * mul
- c66 = c66 + minus_sum_beta * mul
- endif
-
- 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
-
- 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
-
-! note : mesh is built such that anisotropic elements are created first in anisotropic layers,
-! thus they are listed first ( see in create_regions_mesh.f90: perm_layer() ordering )
-! this is therefore still in bounds of 1:NSPECMAX_TISO_MANTLE even if NSPECMAX_TISO is less than NSPEC
-
- ! uncomment to debug
- !if ( ispec > NSPECMAX_TISO_MANTLE ) then
- ! print*,'error tiso: ispec = ',ispec,'max = ',NSPECMAX_TISO_MANTLE
- ! call exit_mpi(0,'error tiso ispec bounds')
- !endif
-
- ! 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
-
- iglob1 = ibool(i,j,k,ispec)
- theta = ystore(iglob1)
- phi = zstore(iglob1)
-
- 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 .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) then
-! way 1:
-! 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
-
-! way 2:
-! note: this should help compilers to pipeline the code and make better use of the cache;
-! depending on compilers, it can further decrease the computation time by ~ 30%.
-! by default, N_SLS = 3, therefore we take steps of 3
- if(imodulo_N_SLS >= 1) then
- do i_SLS = 1,imodulo_N_SLS
- R_xx_val1 = R_memory(1,i_SLS,i,j,k,ispec)
- R_yy_val1 = R_memory(2,i_SLS,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val1
- sigma_yy = sigma_yy - R_yy_val1
- sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
- sigma_xy = sigma_xy - R_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
-
- if(N_SLS >= imodulo_N_SLS+1) then
- do i_SLS = imodulo_N_SLS+1,N_SLS,3
- R_xx_val1 = R_memory(1,i_SLS,i,j,k,ispec)
- R_yy_val1 = R_memory(2,i_SLS,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val1
- sigma_yy = sigma_yy - R_yy_val1
- sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
- sigma_xy = sigma_xy - R_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)
-
- R_xx_val2 = R_memory(1,i_SLS+1,i,j,k,ispec)
- R_yy_val2 = R_memory(2,i_SLS+1,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val2
- sigma_yy = sigma_yy - R_yy_val2
- sigma_zz = sigma_zz + R_xx_val2 + R_yy_val2
- sigma_xy = sigma_xy - R_memory(3,i_SLS+1,i,j,k,ispec)
- sigma_xz = sigma_xz - R_memory(4,i_SLS+1,i,j,k,ispec)
- sigma_yz = sigma_yz - R_memory(5,i_SLS+1,i,j,k,ispec)
-
- R_xx_val3 = R_memory(1,i_SLS+2,i,j,k,ispec)
- R_yy_val3 = R_memory(2,i_SLS+2,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val3
- sigma_yy = sigma_yy - R_yy_val3
- sigma_zz = sigma_zz + R_xx_val3 + R_yy_val3
- sigma_xy = sigma_xy - R_memory(3,i_SLS+2,i,j,k,ispec)
- sigma_xz = sigma_xz - R_memory(4,i_SLS+2,i,j,k,ispec)
- sigma_yz = sigma_yz - R_memory(5,i_SLS+2,i,j,k,ispec)
- enddo
- endif
-
- endif
-
- ! define symmetric components of sigma for gravity
- sigma_yx = sigma_xy
- sigma_zx = sigma_xz
- sigma_zy = sigma_yz
-
- ! compute non-symmetric terms for gravity
- if(GRAVITY_VAL) then
-
- ! use mesh coordinates to get theta and phi
- ! x y and z contain r theta and phi
- iglob1 = ibool(i,j,k,ispec)
- theta = ystore(iglob1)
- phi = zstore(iglob1)
-
- cos_theta = dcos(dble(theta))
- sin_theta = dsin(dble(theta))
- cos_phi = dcos(dble(phi))
- sin_phi = dsin(dble(phi))
-
- cos_theta_sq = cos_theta**2
- sin_theta_sq = sin_theta**2
- cos_phi_sq = cos_phi**2
- sin_phi_sq = sin_phi**2
-
- ! get g, rho and dg/dr=dg
- ! spherical components of the gravitational acceleration
- ! for efficiency replace with lookup table every 100 m in radial direction
- radius = dble(xstore(iglob1))
- int_radius = nint(radius * R_EARTH_KM * 10.d0)
- minus_g = minus_gravity_table(int_radius)
- minus_dg = minus_deriv_gravity_table(int_radius)
- rho = density_table(int_radius)
-
- ! Cartesian components of the gravitational acceleration
- gxl = minus_g*sin_theta*cos_phi
- gyl = minus_g*sin_theta*sin_phi
- gzl = minus_g*cos_theta
-
- ! Cartesian components of gradient of gravitational acceleration
- ! obtained from spherical components
- minus_g_over_radius = minus_g / radius
- minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
-
- Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
- Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
- Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
- Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
- Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
- Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
-
-
- ! for locality principle, we set iglob again, in order to have it in the cache again
- iglob1 = ibool(i,j,k,ispec)
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
-
- ! get displacement and multiply by density to compute G tensor
- sx_l = rho * dble(displ_crust_mantle(1,iglob1))
- sy_l = rho * dble(displ_crust_mantle(2,iglob1))
- sz_l = rho * dble(displ_crust_mantle(3,iglob1))
-
- ! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
- sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
- sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
-
- sigma_xy = sigma_xy - sngl(sx_l * gyl)
- sigma_yx = sigma_yx - sngl(sy_l * gxl)
-
- sigma_xz = sigma_xz - sngl(sx_l * gzl)
- sigma_zx = sigma_zx - sngl(sz_l * gxl)
-
- sigma_yz = sigma_yz - sngl(sy_l * gzl)
- sigma_zy = sigma_zy - sngl(sz_l * gyl)
-
- ! precompute vector
- factor = dble(jacobianl) * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
- rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
- rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
-
- else
-
- ! get displacement and multiply by density to compute G tensor
- sx_l = rho * displ_crust_mantle(1,iglob1)
- sy_l = rho * displ_crust_mantle(2,iglob1)
- sz_l = rho * displ_crust_mantle(3,iglob1)
-
- ! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
- sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
- sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
-
- sigma_xy = sigma_xy - sx_l * gyl
- sigma_yx = sigma_yx - sy_l * gxl
-
- sigma_xz = sigma_xz - sx_l * gzl
- sigma_zx = sigma_zx - sz_l * gxl
-
- sigma_yz = sigma_yz - sy_l * gzl
- sigma_zy = sigma_zy - sz_l * gyl
-
- ! precompute vector
- factor = jacobianl * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
- rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
- rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
-
- endif
-
- endif ! end of section with gravity terms
-
- ! form dot product with test vector, non-symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
- enddo ! NGLLX
- enddo ! NGLLY
- enddo ! NGLLZ
-
- ! subroutines adapted from Deville, Fischer and Mund, High-order methods
- ! for incompressible fluid flow, Cambridge University Press (2002),
- ! pages 386 and 389 and Figure 8.3.1
- do j=1,m2
- do i=1,m1
- E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
-
- E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
-
- E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
- enddo
- enddo
- do i=1,m1
- do j=1,m1
- ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
- tempx2(i,2,k)*hprimewgll_xx(2,j) + &
- tempx2(i,3,k)*hprimewgll_xx(3,j) + &
- tempx2(i,4,k)*hprimewgll_xx(4,j) + &
- tempx2(i,5,k)*hprimewgll_xx(5,j)
-
- newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
- tempy2(i,2,k)*hprimewgll_xx(2,j) + &
- tempy2(i,3,k)*hprimewgll_xx(3,j) + &
- tempy2(i,4,k)*hprimewgll_xx(4,j) + &
- tempy2(i,5,k)*hprimewgll_xx(5,j)
-
- newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
- tempz2(i,2,k)*hprimewgll_xx(2,j) + &
- tempz2(i,3,k)*hprimewgll_xx(3,j) + &
- tempz2(i,4,k)*hprimewgll_xx(4,j) + &
- tempz2(i,5,k)*hprimewgll_xx(5,j)
- enddo
- enddo
- enddo
- do j=1,m1
- do i=1,m2
- E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
-
- E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
-
- E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
-
-! way 1:
-! this seems to be still the fastest way here.
- fac1 = wgllwgll_yz(j,k)
- do i=1,NGLLX
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
-
- ! sum contributions
- sum_terms(1,i,j,k) = - (fac1*newtempx1(i,j,k) + fac2*newtempx2(i,j,k) + fac3*newtempx3(i,j,k))
- sum_terms(2,i,j,k) = - (fac1*newtempy1(i,j,k) + fac2*newtempy2(i,j,k) + fac3*newtempy3(i,j,k))
- sum_terms(3,i,j,k) = - (fac1*newtempz1(i,j,k) + fac2*newtempz2(i,j,k) + fac3*newtempz3(i,j,k))
-
- if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
-
- enddo ! NGLLX
-
- enddo ! NGLLY
- enddo ! NGLLZ
-
- ! sum contributions from each element to the global mesh and add gravity terms
- do k=1,NGLLZ
- do j=1,NGLLY
-! way 1:
-! do i=1,NGLLX
-! iglob = ibool(i,j,k,ispec)
-! accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) + sum_terms(:,i,j,k)
-! enddo
-
-! way 2:
- accel_crust_mantle(:,ibool(1,j,k,ispec)) = accel_crust_mantle(:,ibool(1,j,k,ispec)) + sum_terms(:,1,j,k)
- accel_crust_mantle(:,ibool(2,j,k,ispec)) = accel_crust_mantle(:,ibool(2,j,k,ispec)) + sum_terms(:,2,j,k)
- accel_crust_mantle(:,ibool(3,j,k,ispec)) = accel_crust_mantle(:,ibool(3,j,k,ispec)) + sum_terms(:,3,j,k)
- accel_crust_mantle(:,ibool(4,j,k,ispec)) = accel_crust_mantle(:,ibool(4,j,k,ispec)) + sum_terms(:,4,j,k)
- accel_crust_mantle(:,ibool(5,j,k,ispec)) = accel_crust_mantle(:,ibool(5,j,k,ispec)) + sum_terms(:,5,j,k)
-
- 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
- ! This is because we only implement Q_\mu attenuation and not Q_\kappa.
- ! Note that this does *NOT* imply that there is no attenuation for P waves
- ! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
- ! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
- ! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
- ! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
-
- if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) then
-
- ! use Runge-Kutta scheme to march in time
-
- ! get coefficients for that standard linear solid
- ! IMPROVE we use mu_v here even if there is some anisotropy
- ! IMPROVE we should probably use an average value instead
-
-! way 1:
-! it still seems to be the fastest way here.
- do i_SLS = 1,N_SLS
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- factor_common_c44_muv = factor_common(i_SLS,:,:,:,ispec)
-
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- factor_common_c44_muv = factor_common_c44_muv * c44store(:,:,:,ispec)
- else
- factor_common_c44_muv = factor_common_c44_muv * muvstore(:,:,:,ispec)
- endif
-
- do i_memory = 1,5
- R_memory(i_memory,i_SLS,:,:,:,ispec) = alphaval(i_SLS) * &
- R_memory(i_memory,i_SLS,:,:,:,ispec) + &
- factor_common_c44_muv * &
- (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) then
-! way 1:
- !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
-! way 2:
- do k=1,NGLLZ
- do j=1,NGLLY
- !dummy(:) = epsilondev_loc(:,1,j,k)
-
- epsilondev(:,1,j,k,ispec) = epsilondev_loc(:,1,j,k)
- epsilondev(:,2,j,k,ispec) = epsilondev_loc(:,2,j,k)
- epsilondev(:,3,j,k,ispec) = epsilondev_loc(:,3,j,k)
- epsilondev(:,4,j,k,ispec) = epsilondev_loc(:,4,j,k)
- epsilondev(:,5,j,k,ispec) = epsilondev_loc(:,5,j,k)
- enddo
- enddo
- endif
-
- enddo ! spectral element loop NSPEC_CRUST_MANTLE
-
- end subroutine compute_forces_crust_mantle_Dev
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,682 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core,xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
-!----------------------
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_INNER_CORE,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore,muvstore,ibool,idoubling, &
- c11store,c33store,c12store,c13store,c44store,R_memory,epsilondev,epsilon_trace_over_3,&
- one_minus_sum_beta,alphaval,betaval,gammaval,factor_common, &
- vx,vy,vz,vnspec)
-
- 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(NDIM,NGLOB_INNER_CORE) :: displ_inner_core,accel_inner_core
-
-! 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(NGLLX, NGLLY, NGLLZ) :: factor_common_use
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilon_trace_over_3
-
-! 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
-
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
-! c11store,c33store,c12store,c13store,c44store
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
- c11store,c33store,c12store,c13store,c44store
-
- integer ispec,iglob,ispec_strain
- integer i,j,k,l
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
-
- 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) c11l,c33l,c12l,c13l,c44l
-
- real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
- real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
- real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
-
-! for gravity
- integer int_radius
- real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
- double precision radius,rho,minus_g,minus_dg
- double precision minus_g_over_radius,minus_dg_plus_g_over_radius
- double precision cos_theta,sin_theta,cos_phi,sin_phi
- double precision cos_theta_sq,sin_theta_sq,cos_phi_sq,sin_phi_sq
- double precision theta,phi,factor,gxl,gyl,gzl,sx_l,sy_l,sz_l
- double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
- double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: xstore,ystore,zstore
-
-! this for non blocking MPI
- integer :: iphase,icall
-
- integer :: computed_elements
-
- logical, dimension(NSPEC_INNER_CORE) :: is_on_a_slice_edge_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
-
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
-
- integer :: ichunk,iproc_xi,iproc_eta,myrank
-
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
-
- 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
-
- integer npoin2D_faces_crust_mantle(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_inner_core,npoin2D_eta_inner_core
-
-! 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(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
- integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
-
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
-
- integer :: npoin2D_max_all_CM_IC
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
-
-! 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_chunkcorn_vector,buffer_recv_chunkcorn_vector
-
-! for matching with central cube in inner core
- integer nb_msgs_theor_in_cube, npoin2D_cube_from_slices,iphase_CC
- integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
- double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices
- double precision, dimension(npoin2D_cube_from_slices,NDIM,nb_msgs_theor_in_cube) :: buffer_all_cube_from_slices
- integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
- integer receiver_cube_from_slices
- logical :: INCLUDE_CENTRAL_CUBE
-
-! local to global mapping
- integer NSPEC2D_BOTTOM_INNER_CORE
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
-
-! ****************************************************
-! big loop over all spectral elements in the solid
-! ****************************************************
-
- computed_elements = 0
-
- do ispec = 1,NSPEC_INNER_CORE
-
-! hide communications by computing the edges first
- if((icall == 2 .and. is_on_a_slice_edge_inner_core(ispec)) .or. &
- (icall == 1 .and. .not. is_on_a_slice_edge_inner_core(ispec))) cycle
-
-! exclude fictitious elements in central cube
- if(idoubling(ispec) /= IFLAG_IN_FICTITIOUS_CUBE) then
-
-! process the communications every ELEMENTS_NONBLOCKING elements
- computed_elements = computed_elements + 1
- if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_CM_IC) == 0) then
-
- if(iphase <= 7) call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_CM, &
- NGLOB1D_RADIAL_IC,NCHUNKS_VAL,iphase)
-
- if(INCLUDE_CENTRAL_CUBE) then
- if(iphase > 7 .and. iphase_CC <= 4) &
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,accel_inner_core,NDIM,iphase_CC)
- endif
-
- endif
-
- 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_inner_core(1,iglob)*hp1
- tempy1l = tempy1l + displ_inner_core(2,iglob)*hp1
- tempz1l = tempz1l + displ_inner_core(3,iglob)*hp1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l = tempx2l + displ_inner_core(1,iglob)*hp2
- tempy2l = tempy2l + displ_inner_core(2,iglob)*hp2
- tempz2l = tempz2l + displ_inner_core(3,iglob)*hp2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l = tempx3l + displ_inner_core(1,iglob)*hp3
- tempy3l = tempy3l + displ_inner_core(2,iglob)*hp3
- tempz3l = tempz3l + displ_inner_core(3,iglob)*hp3
- enddo
-
-! get derivatives of ux, uy and uz with respect to x, y and z
-
- 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
- if(NSPEC_INNER_CORE_STRAIN_ONLY == 1) then
- ispec_strain = 1
- else
- ispec_strain = ispec
- endif
- epsilon_trace_over_3(i,j,k,ispec_strain) = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(1,i,j,k) = duxdxl - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(2,i,j,k) = duydyl - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
- endif
-
- if(ATTENUATION_VAL) then
- minus_sum_beta = one_minus_sum_beta(i,j,k,ispec) - 1.0
- endif
-
- if(ANISOTROPIC_INNER_CORE_VAL) then
-
-! elastic tensor for hexagonal symmetry in reduced notation:
-!
-! c11 c12 c13 0 0 0
-! c12 c11 c13 0 0 0
-! c13 c13 c33 0 0 0
-! 0 0 0 c44 0 0
-! 0 0 0 0 c44 0
-! 0 0 0 0 0 (c11-c12)/2
-!
-! in terms of the A, C, L, N and F of Love (1927):
-!
-! c11 = A
-! c12 = A-2N
-! c13 = F
-! c33 = C
-! c44 = L
-
- c11l = c11store(i,j,k,ispec)
- c12l = c12store(i,j,k,ispec)
- c13l = c13store(i,j,k,ispec)
- c33l = c33store(i,j,k,ispec)
- c44l = c44store(i,j,k,ispec)
-
-! use unrelaxed parameters if attenuation
- if(ATTENUATION_VAL) then
- mul = muvstore(i,j,k,ispec)
- c11l = c11l + FOUR_THIRDS * minus_sum_beta * mul
- c12l = c12l - TWO_THIRDS * minus_sum_beta * mul
- c13l = c13l - TWO_THIRDS * minus_sum_beta * mul
- c33l = c33l + FOUR_THIRDS * minus_sum_beta * mul
- c44l = c44l + minus_sum_beta * mul
- endif
-
- sigma_xx = c11l*duxdxl + c12l*duydyl + c13l*duzdzl
- sigma_yy = c12l*duxdxl + c11l*duydyl + c13l*duzdzl
- sigma_zz = c13l*duxdxl + c13l*duydyl + c33l*duzdzl
- sigma_xy = 0.5*(c11l-c12l)*duxdyl_plus_duydxl
- sigma_xz = c44l*duzdxl_plus_duxdzl
- sigma_yz = c44l*duzdyl_plus_duydzl
- else
-
-! 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(i,j,k,ispec)
- 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 .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) 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
-
-! define symmetric components of sigma for gravity
- sigma_yx = sigma_xy
- sigma_zx = sigma_xz
- sigma_zy = sigma_yz
-
-! compute non-symmetric terms for gravity
- if(GRAVITY_VAL) then
-
-! use mesh coordinates to get theta and phi
-! x y and z contain r theta and phi
-
- iglob = ibool(i,j,k,ispec)
- radius = dble(xstore(iglob))
- theta = dble(ystore(iglob))
- phi = dble(zstore(iglob))
-
-! make sure radius is never zero even for points at center of cube
-! because we later divide by radius
- if(radius < 100.d0 / R_EARTH) radius = 100.d0 / R_EARTH
-
- cos_theta = dcos(theta)
- sin_theta = dsin(theta)
- cos_phi = dcos(phi)
- sin_phi = dsin(phi)
-
-! get g, rho and dg/dr=dg
-! spherical components of the gravitational acceleration
-! for efficiency replace with lookup table every 100 m in radial direction
-! make sure we never use zero for point exactly at the center of the Earth
- int_radius = max(1,nint(radius * R_EARTH_KM * 10.d0))
- minus_g = minus_gravity_table(int_radius)
- minus_dg = minus_deriv_gravity_table(int_radius)
- rho = density_table(int_radius)
-
-! Cartesian components of the gravitational acceleration
- gxl = minus_g*sin_theta*cos_phi
- gyl = minus_g*sin_theta*sin_phi
- gzl = minus_g*cos_theta
-
-! Cartesian components of gradient of gravitational acceleration
-! obtained from spherical components
-
- minus_g_over_radius = minus_g / radius
- minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
-
- cos_theta_sq = cos_theta**2
- sin_theta_sq = sin_theta**2
- cos_phi_sq = cos_phi**2
- sin_phi_sq = sin_phi**2
-
- Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
- Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
- Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
- Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
- Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
- Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
-
- iglob = ibool(i,j,k,ispec)
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
-
-! get displacement and multiply by density to compute G tensor
- sx_l = rho * dble(displ_inner_core(1,iglob))
- sy_l = rho * dble(displ_inner_core(2,iglob))
- sz_l = rho * dble(displ_inner_core(3,iglob))
-
-! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
- sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
- sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
-
- sigma_xy = sigma_xy - sngl(sx_l * gyl)
- sigma_yx = sigma_yx - sngl(sy_l * gxl)
-
- sigma_xz = sigma_xz - sngl(sx_l * gzl)
- sigma_zx = sigma_zx - sngl(sz_l * gxl)
-
- sigma_yz = sigma_yz - sngl(sy_l * gzl)
- sigma_zy = sigma_zy - sngl(sz_l * gyl)
-
-! precompute vector
- factor = dble(jacobianl) * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
- rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
- rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
-
- else
-
-! get displacement and multiply by density to compute G tensor
- sx_l = rho * displ_inner_core(1,iglob)
- sy_l = rho * displ_inner_core(2,iglob)
- sz_l = rho * displ_inner_core(3,iglob)
-
-! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
- sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
- sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
-
- sigma_xy = sigma_xy - sx_l * gyl
- sigma_yx = sigma_yx - sy_l * gxl
-
- sigma_xz = sigma_xz - sx_l * gzl
- sigma_zx = sigma_zx - sz_l * gxl
-
- sigma_yz = sigma_yz - sy_l * gzl
- sigma_zy = sigma_zy - sz_l * gyl
-
-! precompute vector
- factor = jacobianl * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
- rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
- rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
-
- endif
-
- endif ! end of section with gravity terms
-
-! form dot product with test vector, non-symmetric form
-
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
-
- 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)
-
- if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
-
- enddo
- enddo
- enddo
-
-! sum contributions from each element to the global mesh and add gravity terms
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- accel_inner_core(:,iglob) = accel_inner_core(:,iglob) + sum_terms(:,i,j,k)
- enddo
- enddo
- enddo
-
-! use Runge-Kutta scheme to march memory variables in time
-! convention for attenuation
-! term in xx = 1
-! term in yy = 2
-! term in xy = 3
-! term in xz = 4
-! term in yz = 5
-! term in zz not computed since zero trace
-! This is because we only implement Q_\mu attenuation and not Q_\kappa.
-! Note that this does *NOT* imply that there is no attenuation for P waves
-! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
-! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
-! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
-! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
-
- if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. )) then
-
- do i_SLS = 1,N_SLS
- factor_common_use = factor_common(i_SLS,:,:,:,ispec)
- do i_memory = 1,5
- R_memory(i_memory,i_SLS,:,:,:,ispec) = &
- alphaval(i_SLS) * &
- R_memory(i_memory,i_SLS,:,:,:,ispec) + muvstore(:,:,:,ispec) * &
- factor_common_use * &
- (betaval(i_SLS) * &
- epsilondev(i_memory,:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
- enddo
- enddo
-
- endif
-
- if (COMPUTE_AND_STORE_STRAIN) then
-! save deviatoric strain for Runge-Kutta scheme
- !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- epsilondev(:,i,j,k,ispec) = epsilondev_loc(:,i,j,k)
- enddo
- enddo
- enddo
-
- endif
-
- endif ! end test to exclude fictitious elements in central cube
-
- enddo ! spectral element loop
-
- end subroutine compute_forces_inner_core
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core_Dev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core_Dev.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core_Dev.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,885 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core,xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
-!----------------------
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_INNER_CORE,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore,muvstore,ibool,idoubling, &
- c11store,c33store,c12store,c13store,c44store,R_memory,epsilondev,epsilon_trace_over_3,&
- one_minus_sum_beta,alphaval,betaval,gammaval,factor_common, &
- vx,vy,vz,vnspec)
-
-! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
-
- 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(NDIM,NGLOB_INNER_CORE) :: displ_inner_core,accel_inner_core
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: xstore,ystore,zstore
-
- ! arrays with mesh parameters per slice
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: xix,xiy,xiz, &
- etax,etay,etaz,gammax,gammay,gammaz
-
- ! for attenuation
- ! memory variables R_ij are stored at the local rather than global level
- ! to allow for optimization of cache access by compiler
- ! variable lengths for factor_common and one_minus_sum_beta
- integer vx, vy, vz, vnspec
- real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: factor_common
- real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
-
- real(kind=CUSTOM_REAL), dimension(NGLLX, NGLLY, NGLLZ) :: factor_common_use
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilon_trace_over_3
-
- ! array with derivatives of Lagrange polynomials and precalculated products
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
- real(kind=CUSTOM_REAL), dimension(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,NSPEC_INNER_CORE) :: kappavstore,muvstore
-
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
-! c11store,c33store,c12store,c13store,c44store
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
- c11store,c33store,c12store,c13store,c44store
-
- ! array with the local to global mapping per slice
- integer, dimension(NSPEC_INNER_CORE) :: idoubling
-
- double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
-
-! local parameters
- ! Deville
- ! manually inline the calls to the Deville et al. (2002) routines
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
- newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
- real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
- real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
- real(kind=CUSTOM_REAL), dimension(m1,m2) :: E1_m1_m2_5points,E2_m1_m2_5points,E3_m1_m2_5points
-
- equivalence(dummyx_loc,B1_m1_m2_5points)
- equivalence(dummyy_loc,B2_m1_m2_5points)
- equivalence(dummyz_loc,B3_m1_m2_5points)
- equivalence(tempx1,C1_m1_m2_5points)
- equivalence(tempy1,C2_m1_m2_5points)
- equivalence(tempz1,C3_m1_m2_5points)
- equivalence(newtempx1,E1_m1_m2_5points)
- equivalence(newtempy1,E2_m1_m2_5points)
- equivalence(newtempz1,E3_m1_m2_5points)
-
- real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: &
- A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
- real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
- C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
- real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
- E1_mxm_m2_m1_5points,E2_mxm_m2_m1_5points,E3_mxm_m2_m1_5points
-
- equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
- equivalence(dummyy_loc,A2_mxm_m2_m1_5points)
- equivalence(dummyz_loc,A3_mxm_m2_m1_5points)
- equivalence(tempx3,C1_mxm_m2_m1_5points)
- equivalence(tempy3,C2_mxm_m2_m1_5points)
- equivalence(tempz3,C3_mxm_m2_m1_5points)
- equivalence(newtempx3,E1_mxm_m2_m1_5points)
- equivalence(newtempy3,E2_mxm_m2_m1_5points)
- equivalence(newtempz3,E3_mxm_m2_m1_5points)
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
- real(kind=CUSTOM_REAL) R_xx_val1,R_yy_val1,R_xx_val2,R_yy_val2,R_xx_val3,R_yy_val3
-
- 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) fac1,fac2,fac3,templ
- real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
- real(kind=CUSTOM_REAL) kappal
-
- real(kind=CUSTOM_REAL) minus_sum_beta
- real(kind=CUSTOM_REAL) c11l,c33l,c12l,c13l,c44l
-
- ! for gravity
- double precision radius,rho,minus_g,minus_dg
- double precision minus_g_over_radius,minus_dg_plus_g_over_radius
- double precision cos_theta,sin_theta,cos_phi,sin_phi
- double precision cos_theta_sq,sin_theta_sq,cos_phi_sq,sin_phi_sq
- double precision theta,phi,factor,gxl,gyl,gzl,sx_l,sy_l,sz_l
- double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
- real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
-
- integer :: int_radius
- integer :: ispec,ispec_strain
- integer :: i,j,k !,l
- integer :: i_SLS,i_memory,imodulo_N_SLS
- integer :: iglob1,iglob2,iglob3,iglob4,iglob5
-
-! this for non blocking MPI
- integer :: iphase,icall
-
- integer :: computed_elements
-
- logical, dimension(NSPEC_INNER_CORE) :: is_on_a_slice_edge_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
-
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
-
- integer :: ichunk,iproc_xi,iproc_eta,myrank
-
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
-
- 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
-
- integer npoin2D_faces_crust_mantle(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_inner_core,npoin2D_eta_inner_core
-
-! 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(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
- integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
-
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
-
- integer :: npoin2D_max_all_CM_IC
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
-
-! 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_chunkcorn_vector,buffer_recv_chunkcorn_vector
-
-! for matching with central cube in inner core
- integer nb_msgs_theor_in_cube, npoin2D_cube_from_slices,iphase_CC
- integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
- double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices
- double precision, dimension(npoin2D_cube_from_slices,NDIM,nb_msgs_theor_in_cube) :: buffer_all_cube_from_slices
- integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
- integer receiver_cube_from_slices
- logical :: INCLUDE_CENTRAL_CUBE
-
-! local to global mapping
- integer NSPEC2D_BOTTOM_INNER_CORE
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
-
-! ****************************************************
-! big loop over all spectral elements in the solid
-! ****************************************************
-
- imodulo_N_SLS = mod(N_SLS,3)
-
- computed_elements = 0
-
- do ispec = 1,NSPEC_INNER_CORE
-
-! hide communications by computing the edges first
- if((icall == 2 .and. is_on_a_slice_edge_inner_core(ispec)) .or. &
- (icall == 1 .and. .not. is_on_a_slice_edge_inner_core(ispec))) cycle
-
- ! exclude fictitious elements in central cube
- if(idoubling(ispec) /= IFLAG_IN_FICTITIOUS_CUBE) then
-
-! process the communications every ELEMENTS_NONBLOCKING elements
- computed_elements = computed_elements + 1
- if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_CM_IC) == 0) then
-
- if(iphase <= 7) call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_CM, &
- NGLOB1D_RADIAL_IC,NCHUNKS_VAL,iphase)
-
- if(INCLUDE_CENTRAL_CUBE) then
- if(iphase > 7 .and. iphase_CC <= 4) &
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,accel_inner_core,NDIM,iphase_CC)
- endif
-
- endif
-
- ! subroutines adapted from Deville, Fischer and Mund, High-order methods
- ! for incompressible fluid flow, Cambridge University Press (2002),
- ! pages 386 and 389 and Figure 8.3.1
- do k=1,NGLLZ
- do j=1,NGLLY
-! way 1:
-! do i=1,NGLLX
-! iglob = ibool(i,j,k,ispec)
-! dummyx_loc(i,j,k) = displ_inner_core(1,iglob)
-! dummyy_loc(i,j,k) = displ_inner_core(2,iglob)
-! dummyz_loc(i,j,k) = displ_inner_core(3,iglob)
-! enddo
-
-! way 2:
- ! since we know that NGLLX = 5, this should help pipelining
- iglob1 = ibool(1,j,k,ispec)
- iglob2 = ibool(2,j,k,ispec)
- iglob3 = ibool(3,j,k,ispec)
- iglob4 = ibool(4,j,k,ispec)
- iglob5 = ibool(5,j,k,ispec)
-
- dummyx_loc(1,j,k) = displ_inner_core(1,iglob1)
- dummyy_loc(1,j,k) = displ_inner_core(2,iglob1)
- dummyz_loc(1,j,k) = displ_inner_core(3,iglob1)
-
- dummyx_loc(2,j,k) = displ_inner_core(1,iglob2)
- dummyy_loc(2,j,k) = displ_inner_core(2,iglob2)
- dummyz_loc(2,j,k) = displ_inner_core(3,iglob2)
-
- dummyx_loc(3,j,k) = displ_inner_core(1,iglob3)
- dummyy_loc(3,j,k) = displ_inner_core(2,iglob3)
- dummyz_loc(3,j,k) = displ_inner_core(3,iglob3)
-
- dummyx_loc(4,j,k) = displ_inner_core(1,iglob4)
- dummyy_loc(4,j,k) = displ_inner_core(2,iglob4)
- dummyz_loc(4,j,k) = displ_inner_core(3,iglob4)
-
- dummyx_loc(5,j,k) = displ_inner_core(1,iglob5)
- dummyy_loc(5,j,k) = displ_inner_core(2,iglob5)
- dummyz_loc(5,j,k) = displ_inner_core(3,iglob5)
-
-
- enddo
- enddo
- do j=1,m2
- do i=1,m1
- C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B1_m1_m2_5points(5,j)
-
- C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B2_m1_m2_5points(5,j)
-
- C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B3_m1_m2_5points(5,j)
- enddo
- enddo
- do j=1,m1
- do i=1,m1
- ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyx_loc(i,5,k)*hprime_xxT(5,j)
-
- tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyy_loc(i,5,k)*hprime_xxT(5,j)
-
- tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyz_loc(i,5,k)*hprime_xxT(5,j)
- enddo
- enddo
- enddo
- do j=1,m1
- do i=1,m2
- C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
-
- C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
-
- C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- ! get derivatives of ux, uy and uz with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
-
- ! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- duxdxl = xixl*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
- duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
- duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
-
- duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
- duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
- duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
-
- duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
- duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
- duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
-
- ! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
-
- ! compute deviatoric strain
- if (COMPUTE_AND_STORE_STRAIN) then
- if(NSPEC_INNER_CORE_STRAIN_ONLY == 1) then
- ispec_strain = 1
- else
- ispec_strain = ispec
- endif
- templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilon_trace_over_3(i,j,k,ispec_strain) = templ
- epsilondev_loc(1,i,j,k) = duxdxl - templ
- epsilondev_loc(2,i,j,k) = duydyl - templ
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
- 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
- minus_sum_beta = one_minus_sum_beta(i,j,k,ispec) - 1.0
- endif
-
- if(ANISOTROPIC_INNER_CORE_VAL) then
- ! elastic tensor for hexagonal symmetry in reduced notation:
- !
- ! c11 c12 c13 0 0 0
- ! c12 c11 c13 0 0 0
- ! c13 c13 c33 0 0 0
- ! 0 0 0 c44 0 0
- ! 0 0 0 0 c44 0
- ! 0 0 0 0 0 (c11-c12)/2
- !
- ! in terms of the A, C, L, N and F of Love (1927):
- !
- ! c11 = A
- ! c12 = A-2N
- ! c13 = F
- ! c33 = C
- ! c44 = L
- c11l = c11store(i,j,k,ispec)
- c12l = c12store(i,j,k,ispec)
- c13l = c13store(i,j,k,ispec)
- c33l = c33store(i,j,k,ispec)
- c44l = c44store(i,j,k,ispec)
-
- ! use unrelaxed parameters if attenuation
- if(ATTENUATION_VAL) then
- mul = muvstore(i,j,k,ispec)
- c11l = c11l + FOUR_THIRDS * minus_sum_beta * mul
- c12l = c12l - TWO_THIRDS * minus_sum_beta * mul
- c13l = c13l - TWO_THIRDS * minus_sum_beta * mul
- c33l = c33l + FOUR_THIRDS * minus_sum_beta * mul
- c44l = c44l + minus_sum_beta * mul
- endif
-
- sigma_xx = c11l*duxdxl + c12l*duydyl + c13l*duzdzl
- sigma_yy = c12l*duxdxl + c11l*duydyl + c13l*duzdzl
- sigma_zz = c13l*duxdxl + c13l*duydyl + c33l*duzdzl
- sigma_xy = 0.5*(c11l-c12l)*duxdyl_plus_duydxl
- sigma_xz = c44l*duzdxl_plus_duxdzl
- sigma_yz = c44l*duzdyl_plus_duydzl
- else
-
- ! 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(i,j,k,ispec)
- 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 .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) then
-
-! way 1:
-! 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
-
-! way 2:
-! note: this should help compilers to pipeline the code and make better use of the cache;
-! depending on compilers, it can further decrease the computation time by ~ 30%.
-! by default, N_SLS = 3, there for we take steps of 3
- if(imodulo_N_SLS >= 1) then
- do i_SLS = 1,imodulo_N_SLS
- R_xx_val1 = R_memory(1,i_SLS,i,j,k,ispec)
- R_yy_val1 = R_memory(2,i_SLS,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val1
- sigma_yy = sigma_yy - R_yy_val1
- sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
- sigma_xy = sigma_xy - R_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
-
- if(N_SLS >= imodulo_N_SLS+1) then
- do i_SLS = imodulo_N_SLS+1,N_SLS,3
- R_xx_val1 = R_memory(1,i_SLS,i,j,k,ispec)
- R_yy_val1 = R_memory(2,i_SLS,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val1
- sigma_yy = sigma_yy - R_yy_val1
- sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
- sigma_xy = sigma_xy - R_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)
-
- R_xx_val2 = R_memory(1,i_SLS+1,i,j,k,ispec)
- R_yy_val2 = R_memory(2,i_SLS+1,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val2
- sigma_yy = sigma_yy - R_yy_val2
- sigma_zz = sigma_zz + R_xx_val2 + R_yy_val2
- sigma_xy = sigma_xy - R_memory(3,i_SLS+1,i,j,k,ispec)
- sigma_xz = sigma_xz - R_memory(4,i_SLS+1,i,j,k,ispec)
- sigma_yz = sigma_yz - R_memory(5,i_SLS+1,i,j,k,ispec)
-
- R_xx_val3 = R_memory(1,i_SLS+2,i,j,k,ispec)
- R_yy_val3 = R_memory(2,i_SLS+2,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val3
- sigma_yy = sigma_yy - R_yy_val3
- sigma_zz = sigma_zz + R_xx_val3 + R_yy_val3
- sigma_xy = sigma_xy - R_memory(3,i_SLS+2,i,j,k,ispec)
- sigma_xz = sigma_xz - R_memory(4,i_SLS+2,i,j,k,ispec)
- sigma_yz = sigma_yz - R_memory(5,i_SLS+2,i,j,k,ispec)
- enddo
- endif
-
- endif
-
- ! define symmetric components of sigma for gravity
- sigma_yx = sigma_xy
- sigma_zx = sigma_xz
- sigma_zy = sigma_yz
-
- ! compute non-symmetric terms for gravity
- if(GRAVITY_VAL) then
-
- ! use mesh coordinates to get theta and phi
- ! x y and z contain r theta and phi
- iglob1 = ibool(i,j,k,ispec)
- radius = dble(xstore(iglob1))
- theta = dble(ystore(iglob1))
- phi = dble(zstore(iglob1))
-
- ! make sure radius is never zero even for points at center of cube
- ! because we later divide by radius
- if(radius < 100.d0 / R_EARTH) radius = 100.d0 / R_EARTH
-
- cos_theta = dcos(theta)
- sin_theta = dsin(theta)
- cos_phi = dcos(phi)
- sin_phi = dsin(phi)
-
- cos_theta_sq = cos_theta**2
- sin_theta_sq = sin_theta**2
- cos_phi_sq = cos_phi**2
- sin_phi_sq = sin_phi**2
-
- ! get g, rho and dg/dr=dg
- ! spherical components of the gravitational acceleration
- ! for efficiency replace with lookup table every 100 m in radial direction
- ! make sure we never use zero for point exactly at the center of the Earth
- int_radius = max(1,nint(radius * R_EARTH_KM * 10.d0))
- minus_g = minus_gravity_table(int_radius)
- minus_dg = minus_deriv_gravity_table(int_radius)
- rho = density_table(int_radius)
-
- ! Cartesian components of the gravitational acceleration
- gxl = minus_g*sin_theta*cos_phi
- gyl = minus_g*sin_theta*sin_phi
- gzl = minus_g*cos_theta
-
- ! Cartesian components of gradient of gravitational acceleration
- ! obtained from spherical components
- minus_g_over_radius = minus_g / radius
- minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
-
- Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
- Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
- Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
- Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
- Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
- Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
-
- ! for locality principle, we set iglob again, in order to have it in the cache again
- iglob1 = ibool(i,j,k,ispec)
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- ! get displacement and multiply by density to compute G tensor
- sx_l = rho * dble(displ_inner_core(1,iglob1))
- sy_l = rho * dble(displ_inner_core(2,iglob1))
- sz_l = rho * dble(displ_inner_core(3,iglob1))
-
- ! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
- sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
- sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
-
- sigma_xy = sigma_xy - sngl(sx_l * gyl)
- sigma_yx = sigma_yx - sngl(sy_l * gxl)
-
- sigma_xz = sigma_xz - sngl(sx_l * gzl)
- sigma_zx = sigma_zx - sngl(sz_l * gxl)
-
- sigma_yz = sigma_yz - sngl(sy_l * gzl)
- sigma_zy = sigma_zy - sngl(sz_l * gyl)
-
- ! precompute vector
- factor = dble(jacobianl) * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
- rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
- rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
-
- else
-
- ! get displacement and multiply by density to compute G tensor
- sx_l = rho * displ_inner_core(1,iglob1)
- sy_l = rho * displ_inner_core(2,iglob1)
- sz_l = rho * displ_inner_core(3,iglob1)
-
- ! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
- sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
- sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
-
- sigma_xy = sigma_xy - sx_l * gyl
- sigma_yx = sigma_yx - sy_l * gxl
-
- sigma_xz = sigma_xz - sx_l * gzl
- sigma_zx = sigma_zx - sz_l * gxl
-
- sigma_yz = sigma_yz - sy_l * gzl
- sigma_zy = sigma_zy - sz_l * gyl
-
- ! precompute vector
- factor = jacobianl * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
- rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
- rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
-
- endif
-
- endif ! end of section with gravity terms
-
- ! form dot product with test vector, non-symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
-
- enddo
- enddo
- enddo
-
- ! subroutines adapted from Deville, Fischer and Mund, High-order methods
- ! for incompressible fluid flow, Cambridge University Press (2002),
- ! pages 386 and 389 and Figure 8.3.1
- do j=1,m2
- do i=1,m1
- E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
-
- E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
-
- E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
- enddo
- enddo
- do i=1,m1
- do j=1,m1
- ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
- tempx2(i,2,k)*hprimewgll_xx(2,j) + &
- tempx2(i,3,k)*hprimewgll_xx(3,j) + &
- tempx2(i,4,k)*hprimewgll_xx(4,j) + &
- tempx2(i,5,k)*hprimewgll_xx(5,j)
-
- newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
- tempy2(i,2,k)*hprimewgll_xx(2,j) + &
- tempy2(i,3,k)*hprimewgll_xx(3,j) + &
- tempy2(i,4,k)*hprimewgll_xx(4,j) + &
- tempy2(i,5,k)*hprimewgll_xx(5,j)
-
- newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
- tempz2(i,2,k)*hprimewgll_xx(2,j) + &
- tempz2(i,3,k)*hprimewgll_xx(3,j) + &
- tempz2(i,4,k)*hprimewgll_xx(4,j) + &
- tempz2(i,5,k)*hprimewgll_xx(5,j)
- enddo
- enddo
- enddo
- do j=1,m1
- do i=1,m2
- E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
-
- E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
-
- E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- fac1 = wgllwgll_yz(j,k)
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
-
- ! sum contributions
- sum_terms(1,i,j,k) = - (fac1*newtempx1(i,j,k) + fac2*newtempx2(i,j,k) + fac3*newtempx3(i,j,k))
- sum_terms(2,i,j,k) = - (fac1*newtempy1(i,j,k) + fac2*newtempy2(i,j,k) + fac3*newtempy3(i,j,k))
- sum_terms(3,i,j,k) = - (fac1*newtempz1(i,j,k) + fac2*newtempz2(i,j,k) + fac3*newtempz3(i,j,k))
-
- if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
-
- enddo
- enddo
- enddo
-
- ! sum contributions from each element to the global mesh and add gravity terms
- do k=1,NGLLZ
- do j=1,NGLLY
-! way 1:
-! do i=1,NGLLX
-! iglob = ibool(i,j,k,ispec)
-! accel_inner_core(:,iglob) = accel_inner_core(:,iglob) + sum_terms(:,i,j,k)
-! enddo
-
-! way 2:
- accel_inner_core(:,ibool(1,j,k,ispec)) = accel_inner_core(:,ibool(1,j,k,ispec)) + sum_terms(:,1,j,k)
- accel_inner_core(:,ibool(2,j,k,ispec)) = accel_inner_core(:,ibool(2,j,k,ispec)) + sum_terms(:,2,j,k)
- accel_inner_core(:,ibool(3,j,k,ispec)) = accel_inner_core(:,ibool(3,j,k,ispec)) + sum_terms(:,3,j,k)
- accel_inner_core(:,ibool(4,j,k,ispec)) = accel_inner_core(:,ibool(4,j,k,ispec)) + sum_terms(:,4,j,k)
- accel_inner_core(:,ibool(5,j,k,ispec)) = accel_inner_core(:,ibool(5,j,k,ispec)) + sum_terms(:,5,j,k)
-
- enddo
- enddo
-
- ! use Runge-Kutta scheme to march memory variables in time
- ! convention for attenuation
- ! term in xx = 1
- ! term in yy = 2
- ! term in xy = 3
- ! term in xz = 4
- ! term in yz = 5
- ! term in zz not computed since zero trace
- ! This is because we only implement Q_\mu attenuation and not Q_\kappa.
- ! Note that this does *NOT* imply that there is no attenuation for P waves
- ! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
- ! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
- ! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
- ! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
- if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) then
- do i_SLS = 1,N_SLS
- factor_common_use = factor_common(i_SLS,:,:,:,ispec)
- do i_memory = 1,5
- R_memory(i_memory,i_SLS,:,:,:,ispec) = &
- alphaval(i_SLS) * &
- R_memory(i_memory,i_SLS,:,:,:,ispec) + muvstore(:,:,:,ispec) * &
- factor_common_use * &
- (betaval(i_SLS) * &
- epsilondev(i_memory,:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
- enddo
- enddo
-
- endif
-
- ! save deviatoric strain for Runge-Kutta scheme
- if(COMPUTE_AND_STORE_STRAIN) then
-! way 1:
- !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
-! way 2:
- do k=1,NGLLZ
- do j=1,NGLLY
- !dummy(:) = epsilondev_loc(:,1,j,k)
-
- epsilondev(:,1,j,k,ispec) = epsilondev_loc(:,1,j,k)
- epsilondev(:,2,j,k,ispec) = epsilondev_loc(:,2,j,k)
- epsilondev(:,3,j,k,ispec) = epsilondev_loc(:,3,j,k)
- epsilondev(:,4,j,k,ispec) = epsilondev_loc(:,4,j,k)
- epsilondev(:,5,j,k,ispec) = epsilondev_loc(:,5,j,k)
- enddo
- enddo
- endif
-
- endif ! end test to exclude fictitious elements in central cube
-
- enddo ! spectral element loop
-
- end subroutine compute_forces_inner_core_Dev
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,397 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation, &
- d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displfluid,accelfluid, &
- div_displfluid, &
- xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool,MOVIE_VOLUME)
-
- 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
-
-! divergence of displacement
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: div_displfluid
-
-! 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
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
-
- logical MOVIE_VOLUME
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: tempx1,tempx2,tempx3
-
-! for gravity
- integer int_radius
- double precision radius,theta,phi,gxl,gyl,gzl
- double precision cos_theta,sin_theta,cos_phi,sin_phi
- double precision, dimension(NRAD_GRAVITY) :: minus_rho_g_over_kappa_fluid
- double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: gravity_term
- real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: xstore,ystore,zstore
-
-! for the Euler scheme for rotation
- real(kind=CUSTOM_REAL) time,deltat,two_omega_earth
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
- A_array_rotation,B_array_rotation
-
- real(kind=CUSTOM_REAL) two_omega_deltat,cos_two_omega_t,sin_two_omega_t,A_rotation,B_rotation, &
- ux_rotation,uy_rotation,dpotentialdx_with_rot,dpotentialdy_with_rot
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: source_euler_A,source_euler_B
-
- integer ispec,iglob
- 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,sum_terms
-
- double precision grad_x_ln_rho,grad_y_ln_rho,grad_z_ln_rho
-
-! this for non blocking MPI
- integer :: ichunk,iproc_xi,iproc_eta,myrank
-
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
-
- 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 npoin2D_faces_outer_core(NUMFACES_SHARED)
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
-
-! 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
-
-! 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,NUMFACES_SHARED) :: iboolfaces_outer_core
-
-! buffers for send and receive between faces of the slices and the chunks
-! we use the same buffers to assemble scalars and vectors because vectors are
-! always three times bigger and therefore scalars can use the first part
-! of the vector buffer in memory even if it has an additional index here
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
- integer :: npoin2D_max_all_CM_IC
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED) :: buffer_send_faces,buffer_received_faces
-
- integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL_OC) :: buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar
-
- logical, dimension(NSPEC_OUTER_CORE) :: is_on_a_slice_edge_outer_core
-
- integer :: iphase,icall
-
- integer :: computed_elements
-
-! ****************************************************
-! big loop over all spectral elements in the fluid
-! ****************************************************
-
- if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. icall == 1) div_displfluid(:,:,:,:) = 0._CUSTOM_REAL
-
- computed_elements = 0
-
- do ispec = 1,NSPEC_OUTER_CORE
-
-! hide communications by computing the edges first
- if((icall == 2 .and. is_on_a_slice_edge_outer_core(ispec)) .or. &
- (icall == 1 .and. .not. is_on_a_slice_edge_outer_core(ispec))) cycle
-
-! process the communications every ELEMENTS_NONBLOCKING elements
- computed_elements = computed_elements + 1
- if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_OC) == 0 .and. iphase <= 7) &
- call assemble_MPI_scalar(myrank,accelfluid,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_OC, &
- NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC,NGLOB2DMAX_XY_VAL,NCHUNKS_VAL,iphase)
-
- 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
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
- tempx1l = tempx1l + displfluid(ibool(l,j,k,ispec)) * hprime_xx(i,l)
- tempx2l = tempx2l + displfluid(ibool(i,l,k,ispec)) * hprime_yy(j,l)
- 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
-
- ! compute contribution of rotation and add to gradient of potential
- ! this term has no Z component
- if(ROTATION_VAL) then
-
- ! store the source for the Euler scheme for A_rotation and B_rotation
- two_omega_deltat = deltat * two_omega_earth
-
- cos_two_omega_t = cos(two_omega_earth*time)
- sin_two_omega_t = sin(two_omega_earth*time)
-
- ! time step deltat of Euler scheme is included in the source
- source_euler_A(i,j,k) = two_omega_deltat * (cos_two_omega_t * dpotentialdyl + sin_two_omega_t * dpotentialdxl)
- source_euler_B(i,j,k) = two_omega_deltat * (sin_two_omega_t * dpotentialdyl - cos_two_omega_t * dpotentialdxl)
-
- A_rotation = A_array_rotation(i,j,k,ispec)
- B_rotation = B_array_rotation(i,j,k,ispec)
-
- ux_rotation = A_rotation*cos_two_omega_t + B_rotation*sin_two_omega_t
- uy_rotation = - A_rotation*sin_two_omega_t + B_rotation*cos_two_omega_t
-
- dpotentialdx_with_rot = dpotentialdxl + ux_rotation
- dpotentialdy_with_rot = dpotentialdyl + uy_rotation
-
- else
-
- dpotentialdx_with_rot = dpotentialdxl
- dpotentialdy_with_rot = dpotentialdyl
-
- endif ! end of section with rotation
-
- ! add (chi/rho)grad(rho) term in no gravity case
- if(.not. GRAVITY_VAL) then
- ! 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
- iglob = ibool(i,j,k,ispec)
-
- 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)
- dpotentialdx_with_rot = dpotentialdx_with_rot + displfluid(iglob) * grad_x_ln_rho
- dpotentialdy_with_rot = dpotentialdy_with_rot + displfluid(iglob) * grad_y_ln_rho
- dpotentialdzl = dpotentialdzl + displfluid(iglob) * grad_z_ln_rho
-
-
- else ! if gravity is turned on
-
- ! compute divergence of displacment
- ! precompute and store gravity term
-
- ! use mesh coordinates to get theta and phi
- ! x y z contain r theta phi
- iglob = ibool(i,j,k,ispec)
-
- 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)
-
- ! get g, rho and dg/dr=dg
- ! spherical components of the gravitational acceleration
- ! for efficiency replace with lookup table every 100 m in radial direction
- int_radius = nint(radius * R_EARTH_KM * 10.d0)
-
- ! Cartesian components of the gravitational acceleration
- ! integrate and multiply by rho / Kappa
- gxl = sin_theta*cos_phi
- gyl = sin_theta*sin_phi
- gzl = cos_theta
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- gravity_term(i,j,k) = &
- sngl(minus_rho_g_over_kappa_fluid(int_radius) * &
- dble(jacobianl) * wgll_cube(i,j,k) * &
- (dble(dpotentialdx_with_rot) * gxl + &
- dble(dpotentialdy_with_rot) * gyl + dble(dpotentialdzl) * gzl))
- else
- gravity_term(i,j,k) = minus_rho_g_over_kappa_fluid(int_radius) * &
- jacobianl * wgll_cube(i,j,k) * (dpotentialdx_with_rot * gxl + &
- dpotentialdy_with_rot * gyl + dpotentialdzl * gzl)
- endif
-
- ! divergence of displacement field with gravity on
- ! note: these calculations are only considered for SIMULATION_TYPE == 1 .and. SAVE_FORWARD
- ! and one has set MOVIE_VOLUME_TYPE == 4 when MOVIE_VOLUME is .true.;
- ! in case of SIMULATION_TYPE == 3, it gets overwritten by compute_kernels_outer_core()
- if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. MOVIE_VOLUME ) then
- div_displfluid(i,j,k,ispec) = &
- minus_rho_g_over_kappa_fluid(int_radius) * (dpotentialdx_with_rot * gxl + &
- dpotentialdy_with_rot * gyl + dpotentialdzl * gzl)
- endif
-
- endif
-
- tempx1(i,j,k) = jacobianl*(xixl*dpotentialdx_with_rot + xiyl*dpotentialdy_with_rot + xizl*dpotentialdzl)
- tempx2(i,j,k) = jacobianl*(etaxl*dpotentialdx_with_rot + etayl*dpotentialdy_with_rot + etazl*dpotentialdzl)
- tempx3(i,j,k) = jacobianl*(gammaxl*dpotentialdx_with_rot + gammayl*dpotentialdy_with_rot + 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
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
- tempx1l = tempx1l + tempx1(l,j,k) * hprimewgll_xx(l,i)
- tempx2l = tempx2l + tempx2(i,l,k) * hprimewgll_yy(l,j)
- tempx3l = tempx3l + tempx3(i,j,l) * hprimewgll_zz(l,k)
- enddo
-
- ! sum contributions from each element to the global mesh and add gravity term
- sum_terms = - (wgllwgll_yz(j,k)*tempx1l + wgllwgll_xz(i,k)*tempx2l + wgllwgll_xy(i,j)*tempx3l)
- if(GRAVITY_VAL) sum_terms = sum_terms + gravity_term(i,j,k)
-
- accelfluid(ibool(i,j,k,ispec)) = accelfluid(ibool(i,j,k,ispec)) + sum_terms
-
- enddo
- enddo
- enddo
-
- ! update rotation term with Euler scheme
- if(ROTATION_VAL) then
- ! use the source saved above
- A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + source_euler_A(:,:,:)
- B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + source_euler_B(:,:,:)
- endif
-
- enddo ! spectral element loop
-
- end subroutine compute_forces_outer_core
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core_Dev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core_Dev.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core_Dev.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,481 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation, &
- d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displfluid,accelfluid, &
- div_displfluid, &
- xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool,MOVIE_VOLUME)
-
-! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
-
- 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
-
-! divergence of displacement
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: div_displfluid
-
-! 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(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
- 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
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
-
- logical MOVIE_VOLUME
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: tempx1,tempx2,tempx3
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: newtempx1,newtempx2,newtempx3
-
-! for gravity
- integer int_radius
- double precision radius,theta,phi,gxl,gyl,gzl
- double precision cos_theta,sin_theta,cos_phi,sin_phi
- double precision, dimension(NRAD_GRAVITY) :: minus_rho_g_over_kappa_fluid
- double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: gravity_term
- real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: xstore,ystore,zstore
-
-! for the Euler scheme for rotation
- real(kind=CUSTOM_REAL) time,deltat,two_omega_earth
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
- A_array_rotation,B_array_rotation
-
- real(kind=CUSTOM_REAL) two_omega_deltat,cos_two_omega_t,sin_two_omega_t,A_rotation,B_rotation, &
- ux_rotation,uy_rotation,dpotentialdx_with_rot,dpotentialdy_with_rot
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: source_euler_A,source_euler_B
-
- integer ispec,iglob
- integer i,j,k
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
- real(kind=CUSTOM_REAL) sum_terms
-
- ! manually inline the calls to the Deville et al. (2002) routines
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points
- real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points
- real(kind=CUSTOM_REAL), dimension(m1,m2) :: E1_m1_m2_5points
-
- equivalence(dummyx_loc,B1_m1_m2_5points)
- equivalence(tempx1,C1_m1_m2_5points)
- equivalence(newtempx1,E1_m1_m2_5points)
-
- real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: A1_mxm_m2_m1_5points
- real(kind=CUSTOM_REAL), dimension(m2,m1) :: C1_mxm_m2_m1_5points
- real(kind=CUSTOM_REAL), dimension(m2,m1) :: E1_mxm_m2_m1_5points
-
- equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
- equivalence(tempx3,C1_mxm_m2_m1_5points)
- equivalence(newtempx3,E1_mxm_m2_m1_5points)
-
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: temp_gxl,temp_gyl,temp_gzl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- displ_times_grad_x_ln_rho,displ_times_grad_y_ln_rho,displ_times_grad_z_ln_rho
-
-! this for non blocking MPI
- integer :: ichunk,iproc_xi,iproc_eta,myrank
-
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
-
- 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 npoin2D_faces_outer_core(NUMFACES_SHARED)
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
-
-! 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
-
-! 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,NUMFACES_SHARED) :: iboolfaces_outer_core
-
-! buffers for send and receive between faces of the slices and the chunks
-! we use the same buffers to assemble scalars and vectors because vectors are
-! always three times bigger and therefore scalars can use the first part
-! of the vector buffer in memory even if it has an additional index here
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
- integer :: npoin2D_max_all_CM_IC
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED) :: buffer_send_faces,buffer_received_faces
-
- integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL_OC) :: buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar
-
- logical, dimension(NSPEC_OUTER_CORE) :: is_on_a_slice_edge_outer_core
-
- integer :: iphase,icall
-
- integer :: computed_elements
-
-! ****************************************************
-! big loop over all spectral elements in the fluid
-! ****************************************************
-
- if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. icall == 1) div_displfluid(:,:,:,:) = 0._CUSTOM_REAL
-
- computed_elements = 0
-
- do ispec = 1,NSPEC_OUTER_CORE
-
-! hide communications by computing the edges first
- if((icall == 2 .and. is_on_a_slice_edge_outer_core(ispec)) .or. &
- (icall == 1 .and. .not. is_on_a_slice_edge_outer_core(ispec))) cycle
-
-! process the communications every ELEMENTS_NONBLOCKING elements
- computed_elements = computed_elements + 1
- if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_OC) == 0 .and. iphase <= 7) &
- call assemble_MPI_scalar(myrank,accelfluid,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_OC, &
- NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC,NGLOB2DMAX_XY_VAL,NCHUNKS_VAL,iphase)
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
-
- ! stores "displacement"
- dummyx_loc(i,j,k) = displfluid(iglob)
-
- ! pre-computes factors
- ! 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)
-
- if( .not. GRAVITY_VAL ) then
- ! grad(rho)/rho in Cartesian components
- displ_times_grad_x_ln_rho(i,j,k) = dummyx_loc(i,j,k) &
- * sngl(sin_theta * cos_phi * d_ln_density_dr_table(int_radius))
- displ_times_grad_y_ln_rho(i,j,k) = dummyx_loc(i,j,k) &
- * sngl(sin_theta * sin_phi * d_ln_density_dr_table(int_radius))
- displ_times_grad_z_ln_rho(i,j,k) = dummyx_loc(i,j,k) &
- * sngl(cos_theta * d_ln_density_dr_table(int_radius))
- else
- ! Cartesian components of the gravitational acceleration
- ! integrate and multiply by rho / Kappa
- temp_gxl(i,j,k) = sin_theta*cos_phi
- temp_gyl(i,j,k) = sin_theta*sin_phi
- temp_gzl(i,j,k) = cos_theta
- endif
-
- enddo
- enddo
- enddo
-
- ! subroutines adapted from Deville, Fischer and Mund, High-order methods
- ! for incompressible fluid flow, Cambridge University Press (2002),
- ! pages 386 and 389 and Figure 8.3.1
- do j=1,m2
- do i=1,m1
- C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B1_m1_m2_5points(5,j)
- enddo
- enddo
- do k = 1,NGLLX
- do j=1,m1
- do i=1,m1
- tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyx_loc(i,5,k)*hprime_xxT(5,j)
- enddo
- enddo
- enddo
- do j=1,m1
- do i=1,m2
- C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- enddo
- enddo
-
-
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- ! 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*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
- dpotentialdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
- dpotentialdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
-
- ! compute contribution of rotation and add to gradient of potential
- ! this term has no Z component
- if(ROTATION_VAL) then
-
- ! store the source for the Euler scheme for A_rotation and B_rotation
- two_omega_deltat = deltat * two_omega_earth
-
- cos_two_omega_t = cos(two_omega_earth*time)
- sin_two_omega_t = sin(two_omega_earth*time)
-
- ! time step deltat of Euler scheme is included in the source
- source_euler_A(i,j,k) = two_omega_deltat &
- * (cos_two_omega_t * dpotentialdyl + sin_two_omega_t * dpotentialdxl)
- source_euler_B(i,j,k) = two_omega_deltat &
- * (sin_two_omega_t * dpotentialdyl - cos_two_omega_t * dpotentialdxl)
-
- A_rotation = A_array_rotation(i,j,k,ispec)
- B_rotation = B_array_rotation(i,j,k,ispec)
-
- ux_rotation = A_rotation*cos_two_omega_t + B_rotation*sin_two_omega_t
- uy_rotation = - A_rotation*sin_two_omega_t + B_rotation*cos_two_omega_t
-
- dpotentialdx_with_rot = dpotentialdxl + ux_rotation
- dpotentialdy_with_rot = dpotentialdyl + uy_rotation
-
- else
-
- dpotentialdx_with_rot = dpotentialdxl
- dpotentialdy_with_rot = dpotentialdyl
-
- endif ! end of section with rotation
-
- ! add (chi/rho)grad(rho) term in no gravity case
- if(.not. GRAVITY_VAL) then
-
- ! 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
- dpotentialdx_with_rot = dpotentialdx_with_rot + displ_times_grad_x_ln_rho(i,j,k)
- dpotentialdy_with_rot = dpotentialdy_with_rot + displ_times_grad_y_ln_rho(i,j,k)
- dpotentialdzl = dpotentialdzl + displ_times_grad_z_ln_rho(i,j,k)
-
- else ! if gravity is turned on
-
- ! compute divergence of displacment
- gxl = temp_gxl(i,j,k)
- gyl = temp_gyl(i,j,k)
- gzl = temp_gzl(i,j,k)
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- gravity_term(i,j,k) = &
- sngl( minus_rho_g_over_kappa_fluid(int_radius) &
- * dble(jacobianl) * wgll_cube(i,j,k) &
- * (dble(dpotentialdx_with_rot) * gxl &
- + dble(dpotentialdy_with_rot) * gyl &
- + dble(dpotentialdzl) * gzl) )
- else
- gravity_term(i,j,k) = minus_rho_g_over_kappa_fluid(int_radius) * &
- jacobianl * wgll_cube(i,j,k) &
- * (dpotentialdx_with_rot * gxl &
- + dpotentialdy_with_rot * gyl &
- + dpotentialdzl * gzl)
- endif
-
- ! divergence of displacement field with gravity on
- ! note: these calculations are only considered for SIMULATION_TYPE == 1 .and. SAVE_FORWARD
- ! and one has set MOVIE_VOLUME_TYPE == 4 when MOVIE_VOLUME is .true.;
- ! in case of SIMULATION_TYPE == 3, it gets overwritten by compute_kernels_outer_core()
- if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. MOVIE_VOLUME) then
- div_displfluid(i,j,k,ispec) = &
- minus_rho_g_over_kappa_fluid(int_radius) &
- * (dpotentialdx_with_rot * gxl &
- + dpotentialdy_with_rot * gyl &
- + dpotentialdzl * gzl)
- endif
-
- endif
-
- tempx1(i,j,k) = jacobianl*(xixl*dpotentialdx_with_rot &
- + xiyl*dpotentialdy_with_rot + xizl*dpotentialdzl)
- tempx2(i,j,k) = jacobianl*(etaxl*dpotentialdx_with_rot &
- + etayl*dpotentialdy_with_rot + etazl*dpotentialdzl)
- tempx3(i,j,k) = jacobianl*(gammaxl*dpotentialdx_with_rot &
- + gammayl*dpotentialdy_with_rot + gammazl*dpotentialdzl)
-
- enddo
- enddo
- enddo
-
- ! subroutines adapted from Deville, Fischer and Mund, High-order methods
- ! for incompressible fluid flow, Cambridge University Press (2002),
- ! pages 386 and 389 and Figure 8.3.1
- do j=1,m2
- do i=1,m1
- E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
- enddo
- enddo
- do k = 1,NGLLX
- do j=1,m1
- do i=1,m1
- newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
- tempx2(i,2,k)*hprimewgll_xx(2,j) + &
- tempx2(i,3,k)*hprimewgll_xx(3,j) + &
- tempx2(i,4,k)*hprimewgll_xx(4,j) + &
- tempx2(i,5,k)*hprimewgll_xx(5,j)
- enddo
- enddo
- enddo
- do j=1,m1
- do i=1,m2
- E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- ! sum contributions from each element to the global mesh and add gravity term
- sum_terms = - (wgllwgll_yz(j,k)*newtempx1(i,j,k) &
- + wgllwgll_xz(i,k)*newtempx2(i,j,k) &
- + wgllwgll_xy(i,j)*newtempx3(i,j,k))
-
- if(GRAVITY_VAL) sum_terms = sum_terms + gravity_term(i,j,k)
-
- iglob = ibool(i,j,k,ispec)
- accelfluid(iglob) = accelfluid(iglob) + sum_terms
-
- enddo
- enddo
- enddo
-
- ! update rotation term with Euler scheme
- if(ROTATION_VAL) then
- ! use the source saved above
- A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + source_euler_A(:,:,:)
- B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + source_euler_B(:,:,:)
- endif
-
- enddo ! spectral element loop
-
- end subroutine compute_forces_outer_core_Dev
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_kernels.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_kernels.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1007 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
- subroutine compute_kernels_crust_mantle(ibool_crust_mantle, &
- rho_kl_crust_mantle,beta_kl_crust_mantle, &
- alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
- accel_crust_mantle,b_displ_crust_mantle, &
- epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
- deltat)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- rho_kl_crust_mantle, beta_kl_crust_mantle, alpha_kl_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- cijkl_kl_crust_mantle
-
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_displ_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- b_epsilondev_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
- eps_trace_over_3_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- b_eps_trace_over_3_crust_mantle
-
- real(kind=CUSTOM_REAL) deltat
-
- ! local parameters
- real(kind=CUSTOM_REAL),dimension(21) :: prod !, cijkl_kl_local
- real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
- real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
- integer :: i,j,k,ispec,iglob
-
- ! crust_mantle
- do ispec = 1, NSPEC_CRUST_MANTLE
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool_crust_mantle(i,j,k,ispec)
-
- ! density kernel: see e.g. Tromp et al.(2005), equation (14)
- ! b_displ_crust_mantle is the backward/reconstructed wavefield, that is s(x,t) in eq. (14),
- ! accel_crust_mantle is the adjoint wavefield, that corresponds to s_dagger(x,T-t)
- !
- ! note with respect to eq. (14) the second time derivative is applied to the
- ! adjoint wavefield here rather than the backward/reconstructed wavefield.
- ! this is a valid operation and the resultant kernel identical to the eq. (14).
- !
- ! reason for this is that the adjoint wavefield is in general smoother
- ! since the adjoint sources normally are obtained for filtered traces.
- ! numerically, the time derivative by a finite-difference scheme should
- ! behave better for smoother wavefields, thus containing less numerical artefacts.
- rho_kl_crust_mantle(i,j,k,ispec) = rho_kl_crust_mantle(i,j,k,ispec) &
- + deltat * (accel_crust_mantle(1,iglob) * b_displ_crust_mantle(1,iglob) &
- + accel_crust_mantle(2,iglob) * b_displ_crust_mantle(2,iglob) &
- + accel_crust_mantle(3,iglob) * b_displ_crust_mantle(3,iglob) )
-
- epsilondev_loc(:) = epsilondev_crust_mantle(:,i,j,k,ispec)
- b_epsilondev_loc(:) = b_epsilondev_crust_mantle(:,i,j,k,ispec)
-
- ! For anisotropic kernels
- if (ANISOTROPIC_KL) then
-
- call compute_strain_product(prod,eps_trace_over_3_crust_mantle(i,j,k,ispec),epsilondev_loc, &
- b_eps_trace_over_3_crust_mantle(i,j,k,ispec),b_epsilondev_loc)
- cijkl_kl_crust_mantle(:,i,j,k,ispec) = cijkl_kl_crust_mantle(:,i,j,k,ispec) + deltat * prod(:)
-
- else
-
- ! kernel for shear modulus, see e.g. Tromp et al. (2005), equation (17)
- ! note: multiplication with 2*mu(x) will be done after the time loop
- beta_kl_crust_mantle(i,j,k,ispec) = beta_kl_crust_mantle(i,j,k,ispec) &
- + deltat * (epsilondev_loc(1)*b_epsilondev_loc(1) + epsilondev_loc(2)*b_epsilondev_loc(2) &
- + (epsilondev_loc(1)+epsilondev_loc(2)) * (b_epsilondev_loc(1)+b_epsilondev_loc(2)) &
- + 2 * (epsilondev_loc(3)*b_epsilondev_loc(3) + epsilondev_loc(4)*b_epsilondev_loc(4) + &
- epsilondev_loc(5)*b_epsilondev_loc(5)) )
-
-
- ! kernel for bulk modulus, see e.g. Tromp et al. (2005), equation (18)
- ! note: multiplication with kappa(x) will be done after the time loop
- alpha_kl_crust_mantle(i,j,k,ispec) = alpha_kl_crust_mantle(i,j,k,ispec) &
- + deltat * (9 * eps_trace_over_3_crust_mantle(i,j,k,ispec) &
- * b_eps_trace_over_3_crust_mantle(i,j,k,ispec))
-
- endif
-
- enddo
- enddo
- enddo
- enddo
-
-
- end subroutine compute_kernels_crust_mantle
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine compute_kernels_outer_core(ibool_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- hprime_xx,hprime_yy,hprime_zz, &
- displ_outer_core,accel_outer_core, &
- b_displ_outer_core,b_accel_outer_core, &
- vector_accel_outer_core,vector_displ_outer_core, &
- b_vector_displ_outer_core, &
- div_displ_outer_core,b_div_displ_outer_core, &
- rhostore_outer_core,kappavstore_outer_core, &
- rho_kl_outer_core,alpha_kl_outer_core, &
- deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
- deltat)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- 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(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
- displ_outer_core,accel_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
- b_displ_outer_core,b_accel_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_OUTER_CORE) :: vector_accel_outer_core,&
- vector_displ_outer_core, b_vector_displ_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: div_displ_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: b_div_displ_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
- rhostore_outer_core,kappavstore_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: &
- rho_kl_outer_core,alpha_kl_outer_core
-
- integer nspec_beta_kl_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_beta_kl_outer_core) :: &
- beta_kl_outer_core
- logical deviatoric_outercore
-
- real(kind=CUSTOM_REAL) deltat
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,kappal
- real(kind=CUSTOM_REAL) :: tempx1l,tempx2l,tempx3l
- real(kind=CUSTOM_REAL) :: tempy1l,tempy2l,tempy3l
- real(kind=CUSTOM_REAL) :: tempz1l,tempz2l,tempz3l
- real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
- real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
-
- integer :: i,j,k,l,ispec,iglob
-
- ! outer_core -- compute the actual displacement and acceleration (NDIM,NGLOBMAX_OUTER_CORE)
- do ispec = 1, NSPEC_OUTER_CORE
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool_outer_core(i,j,k,ispec)
-
- xixl = xix_outer_core(i,j,k,ispec)
- xiyl = xiy_outer_core(i,j,k,ispec)
- xizl = xiz_outer_core(i,j,k,ispec)
- etaxl = etax_outer_core(i,j,k,ispec)
- etayl = etay_outer_core(i,j,k,ispec)
- etazl = etaz_outer_core(i,j,k,ispec)
- gammaxl = gammax_outer_core(i,j,k,ispec)
- gammayl = gammay_outer_core(i,j,k,ispec)
- gammazl = gammaz_outer_core(i,j,k,ispec)
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
-
- do l=1,NGLLX
- tempx1l = tempx1l + b_displ_outer_core(ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
- enddo
-
- do l=1,NGLLY
- tempx2l = tempx2l + b_displ_outer_core(ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
- enddo
-
- do l=1,NGLLZ
- tempx3l = tempx3l + b_displ_outer_core(ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
- enddo
-
- b_vector_displ_outer_core(1,iglob) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- b_vector_displ_outer_core(2,iglob) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- b_vector_displ_outer_core(3,iglob) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
-
- !deviatoric kernel check
- if( deviatoric_outercore ) then
-
- 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
-
- ! assumes NGLLX = NGLLY = NGLLZ
- do l=1,NGLLX
- tempx1l = tempx1l + b_vector_displ_outer_core(1,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
- tempy1l = tempy1l + b_vector_displ_outer_core(2,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
- tempz1l = tempz1l + b_vector_displ_outer_core(3,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
-
- tempx2l = tempx2l + b_vector_displ_outer_core(1,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
- tempy2l = tempy2l + b_vector_displ_outer_core(2,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
- tempz2l = tempz2l + b_vector_displ_outer_core(3,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
-
- tempx3l = tempx3l + b_vector_displ_outer_core(1,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
- tempy3l = tempy3l + b_vector_displ_outer_core(2,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
- tempz3l = tempz3l + b_vector_displ_outer_core(3,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
- enddo
-
-
- !deviatoric strain
- b_epsilondev_loc(1) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
- b_epsilondev_loc(2) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
- b_epsilondev_loc(3) = 0.5*( xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l &
- + xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l ) &
- - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
- b_epsilondev_loc(4) = 0.5*( xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l &
- + xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l ) &
- - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
- b_epsilondev_loc(5) = 0.5*( xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l &
- + xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l ) &
- - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
- endif !deviatoric kernel check
-
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- tempx1l = tempx1l + accel_outer_core(ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
- enddo
-
- do l=1,NGLLY
- tempx2l = tempx2l + accel_outer_core(ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
- enddo
-
- do l=1,NGLLZ
- tempx3l = tempx3l + accel_outer_core(ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
- enddo
-
- vector_accel_outer_core(1,iglob) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- vector_accel_outer_core(2,iglob) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- vector_accel_outer_core(3,iglob) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- tempx1l = tempx1l + displ_outer_core(ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
- enddo
-
- do l=1,NGLLY
- tempx2l = tempx2l + displ_outer_core(ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
- enddo
-
- do l=1,NGLLZ
- tempx3l = tempx3l + displ_outer_core(ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
- enddo
-
- vector_displ_outer_core(1,iglob) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- vector_displ_outer_core(2,iglob) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- vector_displ_outer_core(3,iglob) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
-
- !deviatoric kernel check
- if( deviatoric_outercore ) then
-
- 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
-
- ! assumes NGLLX = NGLLY = NGLLZ
- do l=1,NGLLX
- tempx1l = tempx1l + vector_displ_outer_core(1,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
- tempy1l = tempy1l + vector_displ_outer_core(2,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
- tempz1l = tempz1l + vector_displ_outer_core(3,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
-
- tempx2l = tempx2l + vector_displ_outer_core(1,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
- tempy2l = tempy2l + vector_displ_outer_core(2,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
- tempz2l = tempz2l + vector_displ_outer_core(3,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
-
- tempx3l = tempx3l + vector_displ_outer_core(1,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
- tempy3l = tempy3l + vector_displ_outer_core(2,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
- tempz3l = tempz3l + vector_displ_outer_core(3,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
- enddo
-
-
- !deviatoric strain
- epsilondev_loc(1) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
- epsilondev_loc(2) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
- epsilondev_loc(3) = 0.5*( xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l &
- + xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l ) &
- - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
- epsilondev_loc(4) = 0.5*( xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l &
- + xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l ) &
- - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
- epsilondev_loc(5) = 0.5*( xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l &
- + xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l ) &
- - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
- beta_kl_outer_core(i,j,k,ispec) = beta_kl_outer_core(i,j,k,ispec) &
- + deltat * (epsilondev_loc(1)*b_epsilondev_loc(1) + epsilondev_loc(2)*b_epsilondev_loc(2) &
- + (epsilondev_loc(1)+epsilondev_loc(2)) * (b_epsilondev_loc(1)+b_epsilondev_loc(2)) &
- + 2 * (epsilondev_loc(3)*b_epsilondev_loc(3) + epsilondev_loc(4)*b_epsilondev_loc(4) + &
- epsilondev_loc(5)*b_epsilondev_loc(5)) )
-
- endif !deviatoric kernel check
-
-
-
- rho_kl_outer_core(i,j,k,ispec) = rho_kl_outer_core(i,j,k,ispec) &
- + deltat * dot_product(vector_accel_outer_core(:,iglob), b_vector_displ_outer_core(:,iglob))
-
- kappal = rhostore_outer_core(i,j,k,ispec)/kappavstore_outer_core(i,j,k,ispec)
-
- div_displ_outer_core(i,j,k,ispec) = kappal * accel_outer_core(iglob)
- b_div_displ_outer_core(i,j,k,ispec) = kappal * b_accel_outer_core(iglob)
-
- alpha_kl_outer_core(i,j,k,ispec) = alpha_kl_outer_core(i,j,k,ispec) &
- + deltat * div_displ_outer_core(i,j,k,ispec) * b_div_displ_outer_core(i,j,k,ispec)
-
-
- enddo
- enddo
- enddo
- enddo
-
- end subroutine compute_kernels_outer_core
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine compute_kernels_inner_core(ibool_inner_core, &
- rho_kl_inner_core,beta_kl_inner_core, &
- alpha_kl_inner_core, &
- accel_inner_core,b_displ_inner_core, &
- epsilondev_inner_core,b_epsilondev_inner_core, &
- eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
- deltat)
-
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- rho_kl_inner_core, beta_kl_inner_core, alpha_kl_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
- accel_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
- b_displ_inner_core
-
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: &
- epsilondev_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- b_epsilondev_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STRAIN_ONLY) :: &
- eps_trace_over_3_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- b_eps_trace_over_3_inner_core
-
- real(kind=CUSTOM_REAL) deltat
-
- ! local parameters
- real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
- real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
-
- integer :: i,j,k,ispec,iglob
-
-
- ! inner_core
- do ispec = 1, NSPEC_INNER_CORE
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool_inner_core(i,j,k,ispec)
-
- rho_kl_inner_core(i,j,k,ispec) = rho_kl_inner_core(i,j,k,ispec) &
- + deltat * (accel_inner_core(1,iglob) * b_displ_inner_core(1,iglob) &
- + accel_inner_core(2,iglob) * b_displ_inner_core(2,iglob) &
- + accel_inner_core(3,iglob) * b_displ_inner_core(3,iglob) )
-
- epsilondev_loc(:) = epsilondev_inner_core(:,i,j,k,ispec)
- b_epsilondev_loc(:) = b_epsilondev_inner_core(:,i,j,k,ispec)
- beta_kl_inner_core(i,j,k,ispec) = beta_kl_inner_core(i,j,k,ispec) &
- + deltat * (epsilondev_loc(1)*b_epsilondev_loc(1) + epsilondev_loc(2)*b_epsilondev_loc(2) &
- + (epsilondev_loc(1)+epsilondev_loc(2)) * (b_epsilondev_loc(1)+b_epsilondev_loc(2)) &
- + 2 * (epsilondev_loc(3)*b_epsilondev_loc(3) + epsilondev_loc(4)*b_epsilondev_loc(4) &
- + epsilondev_loc(5)*b_epsilondev_loc(5)) )
-
- alpha_kl_inner_core(i,j,k,ispec) = alpha_kl_inner_core(i,j,k,ispec) &
- + deltat * (9 * eps_trace_over_3_inner_core(i,j,k,ispec) * b_eps_trace_over_3_inner_core(i,j,k,ispec))
- enddo
- enddo
- enddo
- enddo
-
- end subroutine compute_kernels_inner_core
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-! Subroutines to compute the kernels for the 21 elastic coefficients
-! Last modified 19/04/2007
-
-!-------------------------------------------------------------------
- subroutine compute_strain_product(prod,eps_trace_over_3,epsdev,&
- b_eps_trace_over_3,b_epsdev)
-
- ! Purpose : compute the 21 strain products at a grid point
- ! (ispec,i,j,k fixed) and at a time t to compute then the kernels cij_kl (Voigt notation)
- ! (eq. 15 of Tromp et al., 2005)
- ! prod(1)=eps11*eps11 -> c11, prod(2)=eps11eps22 -> c12, prod(3)=eps11eps33 -> c13, ...
- ! prod(7)=eps22*eps22 -> c22, prod(8)=eps22eps33 -> c23, prod(9)=eps22eps23 -> c24, ...
- ! prod(19)=eps13*eps13 -> c55, prod(20)=eps13eps12 -> c56, prod(21)=eps12eps12 -> c66
- ! This then gives how the 21 kernels are organized
- ! For crust_mantle
-
- ! Modif 09/11/2005
-
- implicit none
- include "constants.h"
-
- real(kind=CUSTOM_REAL),dimension(21) :: prod
- real(kind=CUSTOM_REAL) :: eps_trace_over_3,b_eps_trace_over_3
- real(kind=CUSTOM_REAL),dimension(5) :: epsdev,b_epsdev
-
- real(kind=CUSTOM_REAL), dimension(6) :: eps,b_eps
- integer :: p,i,j
-
- ! Building of the local matrix of the strain tensor
- ! for the adjoint field and the regular backward field
- eps(1:2)=epsdev(1:2)+eps_trace_over_3 !eps11 et eps22
- eps(3)=-(eps(1)+eps(2))+3*eps_trace_over_3 !eps33
- eps(4)=epsdev(5) !eps23
- eps(5)=epsdev(4) !eps13
- eps(6)=epsdev(3) !eps12
-
- b_eps(1:2)=b_epsdev(1:2)+b_eps_trace_over_3
- b_eps(3)=-(b_eps(1)+b_eps(2))+3*b_eps_trace_over_3
- b_eps(4)=b_epsdev(5)
- b_eps(5)=b_epsdev(4)
- b_eps(6)=b_epsdev(3)
-
- ! Computing the 21 strain products without assuming eps(i)*b_eps(j) = eps(j)*b_eps(i)
- p=1
- do i=1,6
- do j=i,6
- prod(p)=eps(i)*b_eps(j)
- if(j>i) then
- prod(p)=prod(p)+eps(j)*b_eps(i)
- if(j>3 .and. i<4) prod(p)=prod(p)*2
- endif
- if(i>3) prod(p)=prod(p)*4
- p=p+1
- enddo
- enddo
-
- end subroutine compute_strain_product
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine rotate_kernels_dble(cij_kl,cij_kll,theta_in,phi_in)
-
-! Purpose : compute the kernels in r,theta,phi (cij_kll)
-! from the kernels in x,y,z (cij_kl) (x,y,z <-> r,theta,phi)
-! At r,theta,phi fixed
-! theta and phi are in radians
-
-! Coeff from Min's routine rotate_anisotropic_tensor
-! with the help of Collect[Expand[cij],{dij}] in Mathematica
-
-! Definition of the output array cij_kll :
-! cij_kll(1) = C11 ; cij_kll(2) = C12 ; cij_kll(3) = C13
-! cij_kll(4) = C14 ; cij_kll(5) = C15 ; cij_kll(6) = C16
-! cij_kll(7) = C22 ; cij_kll(8) = C23 ; cij_kll(9) = C24
-! cij_kll(10) = C25 ; cij_kll(11) = C26 ; cij_kll(12) = C33
-! cij_kll(13) = C34 ; cij_kll(14) = C35 ; cij_kll(15) = C36
-! cij_kll(16) = C44 ; cij_kll(17) = C45 ; cij_kll(18) = C46
-! cij_kll(19) = C55 ; cij_kll(20) = C56 ; cij_kll(21) = C66
-! where the Cij (Voigt's notation) are defined as function of
-! the components of the elastic tensor in spherical coordinates
-! by eq. (A.1) of Chen & Tromp, GJI 168 (2007)
-
- implicit none
- include "constants.h"
-
- real(kind=CUSTOM_REAL) :: theta_in,phi_in
- real(kind=CUSTOM_REAL),dimension(21) :: cij_kll,cij_kl
-
- double precision :: theta,phi
- double precision :: costheta,sintheta,cosphi,sinphi
- double precision :: costhetasq,sinthetasq,cosphisq,sinphisq
- double precision :: costwotheta,sintwotheta,costwophi,sintwophi
- double precision :: cosfourtheta,sinfourtheta,cosfourphi,sinfourphi
- double precision :: costhetafour,sinthetafour,cosphifour,sinphifour
- double precision :: sintwophisq,sintwothetasq
- double precision :: costhreetheta,sinthreetheta,costhreephi,sinthreephi
-
-
- if (CUSTOM_REAL == SIZE_REAL) then
- theta = dble(theta_in)
- phi = dble(phi_in)
- else
- theta = theta_in
- phi = phi_in
- endif
-
- 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)
-
- costhreetheta=dcos(3.d0*theta)
- sinthreetheta=dsin(3.d0*theta)
- costhreephi=dcos(3.d0*phi)
- sinthreephi=dsin(3.d0*phi)
-
- cosfourtheta = dcos(4.d0*theta)
- sinfourtheta = dsin(4.d0*theta)
- cosfourphi = dcos(4.d0*phi)
- sinfourphi = dsin(4.d0*phi)
- sintwothetasq = sintwotheta * sintwotheta
- sintwophisq = sintwophi * sintwophi
-
-
- cij_kll(1) = 1.d0/16.d0* (cij_kl(16) - cij_kl(16)* costwophi + &
- 16.d0* cosphi*cosphisq* costhetafour* (cij_kl(1)* cosphi + cij_kl(6)* sinphi) + &
- 2.d0* (cij_kl(15) + cij_kl(17))* sintwophi* sintwothetasq - &
- 2.d0* (cij_kl(16)* cosfourtheta* sinphisq + &
- 2.d0* costhetafour* (-4* cij_kl(7)* sinphifour - &
- (cij_kl(2) + cij_kl(21))* sintwophisq) + &
- 8.d0* cij_kl(5)* cosphi*cosphisq* costheta*costhetasq* sintheta - &
- 8.d0* cij_kl(8)* costhetasq* sinphisq* sinthetasq - &
- 8.d0* cij_kl(12)* sinthetafour + &
- 8.d0* cosphisq* costhetasq* sintheta* ((cij_kl(4) + &
- cij_kl(20))* costheta* sinphi - &
- (cij_kl(3) + cij_kl(19))*sintheta) + &
- 8.d0* cosphi* costheta* (-cij_kl(11)* costheta*costhetasq* &
- sinphi*sinphisq + (cij_kl(10) + cij_kl(18))* costhetasq* sinphisq* sintheta + &
- cij_kl(14)* sintheta*sinthetasq) + 2.d0* sinphi* (cij_kl(13) + &
- cij_kl(9)* sinphisq)* sintwotheta + &
- sinphi* (-cij_kl(13) + cij_kl(9)* sinphisq)* sinfourtheta))
-
- cij_kll(2) = 1.d0/4.d0* (costhetasq* (cij_kl(1) + 3.d0* cij_kl(2) + cij_kl(7) - &
- cij_kl(21) + (-cij_kl(1) + cij_kl(2) - cij_kl(7) + &
- cij_kl(21))* cosfourphi + (-cij_kl(6) + cij_kl(11))* sinfourphi) + &
- 4.d0* (cij_kl(8)* cosphisq - cij_kl(15)* cosphi* sinphi + &
- cij_kl(3)* sinphisq)* sinthetasq - &
- 2.d0* (cij_kl(10)* cosphisq*cosphi + &
- (cij_kl(9) - cij_kl(20))* cosphisq* sinphi + &
- (cij_kl(5) - cij_kl(18))* cosphi* sinphisq + &
- cij_kl(4)* sinphisq*sinphi)* sintwotheta)
-
- cij_kll(3) = 1.d0/8.d0* (sintwophi* (3.d0* cij_kl(15) - cij_kl(17) + &
- 4.d0* (cij_kl(2) + cij_kl(21))* costhetasq* sintwophi* sinthetasq) + &
- 4.d0* cij_kl(12)* sintwothetasq + 4.d0* cij_kl(1)* cosphifour* sintwothetasq + &
- 2.d0* cosphi*cosphisq* (8.d0* cij_kl(6)* costhetasq* sinphi* sinthetasq + &
- cij_kl(5)* sinfourtheta) + 2.d0* cosphisq* (3.d0* cij_kl(3) - cij_kl(19) + &
- (cij_kl(3) + cij_kl(19))* cosfourtheta + &
- (cij_kl(4) + cij_kl(20))* sinphi* sinfourtheta) + &
- 2.d0* sinphi* (sinphi* (3.d0* cij_kl(8) - &
- cij_kl(16) + (cij_kl(8) + cij_kl(16))* cosfourtheta + &
- 2.d0* cij_kl(7)* sinphisq* sintwothetasq)+ &
- (-cij_kl(13) + cij_kl(9)* sinphisq)* sinfourtheta)+ &
- 2.d0* cosphi* ((cij_kl(15) + cij_kl(17))* cosfourtheta* sinphi + &
- 8.d0* cij_kl(11)* costhetasq* sinphi*sinphisq* sinthetasq + &
- (-cij_kl(14) + (cij_kl(10) + cij_kl(18))* sinphisq)*sinfourtheta))
-
- cij_kll(4) = 1.d0/8.d0* (cosphi* costheta *(5.d0* cij_kl(4) - &
- cij_kl(9) + 4.d0* cij_kl(13) - &
- 3.d0* cij_kl(20) + (cij_kl(4) + 3.d0* cij_kl(9) - &
- 4.d0* cij_kl(13) + cij_kl(20))* costwotheta) + &
- 1.d0/2.d0* (cij_kl(4) - cij_kl(9) + &
- cij_kl(20))* costhreephi * (costheta + 3.d0* costhreetheta) - &
- costheta* (-cij_kl(5) + 5.d0* cij_kl(10) + &
- 4.d0* cij_kl(14) - 3.d0* cij_kl(18) + &
- (3.d0* cij_kl(5) + cij_kl(10) - &
- 4.d0* cij_kl(14) + cij_kl(18))* costwotheta)* sinphi - &
- 1.d0/2.d0* (cij_kl(5) - cij_kl(10) - cij_kl(18))* (costheta + &
- 3.d0* costhreetheta)* sinthreephi + &
- 4.d0* (cij_kl(6) - cij_kl(11))* cosfourphi* costhetasq* sintheta - &
- 4.d0* (cij_kl(1) + cij_kl(3) - cij_kl(7) - cij_kl(8) + cij_kl(16) - cij_kl(19) + &
- (cij_kl(1) - cij_kl(3) - cij_kl(7) + cij_kl(8) + &
- cij_kl(16) - cij_kl(19))* costwotheta)* sintwophi* sintheta - &
- 4.d0* (cij_kl(1) - cij_kl(2) + cij_kl(7) - &
- cij_kl(21))* costhetasq* sinfourphi* sintheta + &
- costwophi* ((cij_kl(6) + cij_kl(11) + 6.d0* cij_kl(15) - &
- 2.d0* cij_kl(17))* sintheta + &
- (cij_kl(6) + cij_kl(11) - 2.d0* (cij_kl(15) + cij_kl(17)))* sinthreetheta))
-
- cij_kll(5) = 1.d0/4.d0* (2.d0* (cij_kl(4) + &
- cij_kl(20))* cosphisq* (costwotheta + cosfourtheta)* sinphi + &
- 2.d0* cij_kl(9)* (costwotheta + cosfourtheta)* sinphi*sinphisq + &
- 16.d0* cij_kl(1)* cosphifour* costheta*costhetasq* sintheta + &
- 4.d0* costheta*costhetasq* (-2.d0* cij_kl(8)* sinphisq + &
- 4.d0* cij_kl(7)* sinphifour + &
- (cij_kl(2) + cij_kl(21))* sintwophisq)* sintheta + &
- 4.d0* cij_kl(13)* (1.d0 + 2.d0* costwotheta)* sinphi* sinthetasq + &
- 8.d0* costheta* (-2.d0* cij_kl(12) + cij_kl(8)* sinphisq)* sintheta*sinthetasq + &
- 2.d0* cosphi*cosphisq* (cij_kl(5)* (costwotheta + cosfourtheta) + &
- 8.d0* cij_kl(6)* costheta*costhetasq* sinphi* sintheta) + &
- 2.d0* cosphi* (cosfourtheta* (-cij_kl(14) + (cij_kl(10) + cij_kl(18))* sinphisq) + &
- costwotheta* (cij_kl(14) + (cij_kl(10) + cij_kl(18))* sinphisq) + &
- 8.d0* cij_kl(11)* costheta*costhetasq* sinphi*sinphisq* sintheta) - &
- (cij_kl(3) + cij_kl(16) + cij_kl(19) + &
- (cij_kl(3) - cij_kl(16) + cij_kl(19))* costwophi + &
- (cij_kl(15) + cij_kl(17))* sintwophi)* sinfourtheta)
-
- cij_kll(6) = 1.d0/2.d0* costheta*costhetasq* ((cij_kl(6) + cij_kl(11))* costwophi + &
- (cij_kl(6) - cij_kl(11))* cosfourphi + 2.d0* (-cij_kl(1) + cij_kl(7))* sintwophi + &
- (-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(21))* sinfourphi) + &
- 1.d0/4.d0* costhetasq* (-(cij_kl(4) + 3* cij_kl(9) + cij_kl(20))* cosphi - &
- 3.d0* (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi + &
- (3.d0* cij_kl(5) + cij_kl(10) + cij_kl(18))* sinphi + &
- 3.d0* (cij_kl(5) - cij_kl(10) - cij_kl(18))* sinthreephi)* sintheta + &
- costheta* ((cij_kl(15) + cij_kl(17))* costwophi + &
- (-cij_kl(3) + cij_kl(8) + cij_kl(16) - cij_kl(19))* sintwophi)* sinthetasq + &
- (-cij_kl(13)* cosphi + cij_kl(14)* sinphi)* sintheta*sinthetasq
-
- cij_kll(7) = cij_kl(7)* cosphifour - cij_kl(11)* cosphi*cosphisq* sinphi + &
- (cij_kl(2) + cij_kl(21))* cosphisq* sinphisq - &
- cij_kl(6)* cosphi* sinphi*sinphisq + &
- cij_kl(1)* sinphifour
-
- cij_kll(8) = 1.d0/2.d0* (2.d0* costhetasq* sinphi* (-cij_kl(15)* cosphi + &
- cij_kl(3)* sinphi) + 2.d0* cij_kl(2)* cosphifour* sinthetasq + &
- (2.d0* cij_kl(2)* sinphifour + &
- (cij_kl(1) + cij_kl(7) - cij_kl(21))* sintwophisq)* sinthetasq + &
- cij_kl(4)* sinphi*sinphisq* sintwotheta + &
- cosphi*cosphisq* (2.d0* (-cij_kl(6) + cij_kl(11))* sinphi* sinthetasq + &
- cij_kl(10)* sintwotheta) + cosphi* sinphisq* (2.d0* (cij_kl(6) - &
- cij_kl(11))* sinphi* sinthetasq + &
- (cij_kl(5) - cij_kl(18))* sintwotheta) + &
- cosphisq* (2.d0* cij_kl(8)* costhetasq + &
- (cij_kl(9) - cij_kl(20))* sinphi* sintwotheta))
-
- cij_kll(9) = cij_kl(11)* cosphifour* sintheta - sinphi*sinphisq* (cij_kl(5)* costheta + &
- cij_kl(6)* sinphi* sintheta) + cosphisq* sinphi* (-(cij_kl(10) + &
- cij_kl(18))* costheta + &
- 3.d0* (cij_kl(6) - cij_kl(11))* sinphi* sintheta) + &
- cosphi* sinphisq* ((cij_kl(4) + cij_kl(20))* costheta + &
- 2.d0* (-2.d0* cij_kl(1) + cij_kl(2) + cij_kl(21))* sinphi* sintheta) + &
- cosphi*cosphisq* (cij_kl(9)* costheta - 2.d0* (cij_kl(2) - 2.d0* cij_kl(7) + &
- cij_kl(21))* sinphi* sintheta)
-
- cij_kll(10) = 1.d0/4.d0* (4.d0* costwotheta* (cij_kl(10)* cosphi*cosphisq + &
- (cij_kl(9) - cij_kl(20))* cosphisq* sinphi + &
- (cij_kl(5) - cij_kl(18))* cosphi* sinphisq + &
- cij_kl(4)* sinphi*sinphisq) + (cij_kl(1) + 3.d0* cij_kl(2) - &
- 2.d0* cij_kl(3) + cij_kl(7) - &
- 2.d0* cij_kl(8) - cij_kl(21) + 2.d0* (cij_kl(3) - cij_kl(8))* costwophi + &
- (-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(21))* cosfourphi + &
- 2.d0* cij_kl(15)* sintwophi + &
- (-cij_kl(6) + cij_kl(11))* sinfourphi)* sintwotheta)
-
- cij_kll(11) = 1.d0/4.d0* (2.d0* costheta* ((cij_kl(6) + cij_kl(11))* costwophi + &
- (-cij_kl(6) + cij_kl(11))* cosfourphi + &
- 2.d0* (-cij_kl(1) + cij_kl(7))* sintwophi + &
- (cij_kl(1) - cij_kl(2) + cij_kl(7) - cij_kl(21))* sinfourphi) + &
- (-(cij_kl(4) + 3.d0* cij_kl(9) + cij_kl(20))* cosphi + &
- (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi + &
- (3.d0* cij_kl(5) + cij_kl(10) + cij_kl(18))* sinphi + &
- (-cij_kl(5) + cij_kl(10) + cij_kl(18))* sinthreephi)* sintheta)
-
- cij_kll(12) = 1.d0/16.d0* (cij_kl(16) - 2.d0* cij_kl(16)* cosfourtheta* sinphisq + &
- costwophi* (-cij_kl(16) + 8.d0* costheta* sinthetasq* ((cij_kl(3) - &
- cij_kl(8) + cij_kl(19))* costheta + &
- (cij_kl(5) - cij_kl(10) - cij_kl(18))* cosphi* sintheta)) + &
- 2.d0* (cij_kl(15) + cij_kl(17))* sintwophi* sintwothetasq + &
- 2.d0* (8.d0* cij_kl(12)* costhetafour + &
- 8.d0* cij_kl(14)* cosphi* costheta*costhetasq* sintheta + &
- 4.d0* cosphi* costheta* (cij_kl(5) + cij_kl(10) + cij_kl(18) + &
- (cij_kl(4) + cij_kl(20))* sintwophi)* &
- sintheta*sinthetasq + 8.d0* cij_kl(1)* cosphifour* sinthetafour + &
- 8.d0* cij_kl(6)* cosphi*cosphisq* sinphi* sinthetafour + &
- 8.d0* cij_kl(11)* cosphi* sinphi*sinphisq* sinthetafour + &
- 8.d0* cij_kl(7)* sinphifour* sinthetafour + &
- 2.d0* cij_kl(2)* sintwophisq* sinthetafour + &
- 2.d0* cij_kl(21)* sintwophisq* sinthetafour + &
- 2.d0* cij_kl(13)* sinphi* sintwotheta + &
- 2.d0* cij_kl(9)* sinphi*sinphisq* sintwotheta + &
- cij_kl(3)* sintwothetasq + cij_kl(8)* sintwothetasq + &
- cij_kl(19)* sintwothetasq + cij_kl(13)* sinphi* sinfourtheta - &
- cij_kl(9)* sinphi*sinphisq* sinfourtheta))
-
- cij_kll(13) = 1.d0/8.d0* (cosphi* costheta* (cij_kl(4) + 3.d0* cij_kl(9) + &
- 4.d0* cij_kl(13) + cij_kl(20) - (cij_kl(4) + 3.d0* cij_kl(9) - &
- 4.d0* cij_kl(13) + cij_kl(20))* costwotheta) + 4.d0* (-cij_kl(1) - &
- cij_kl(3) + cij_kl(7) + cij_kl(8) + cij_kl(16) - cij_kl(19) + &
- (cij_kl(1) - cij_kl(3) - cij_kl(7) + cij_kl(8) + cij_kl(16) - &
- cij_kl(19))* costwotheta)* sintwophi* sintheta + &
- 4.d0* (cij_kl(6) - cij_kl(11))* cosfourphi* sinthetasq*sintheta - &
- 4.d0* (cij_kl(1) - cij_kl(2) + cij_kl(7) - &
- cij_kl(21))* sinfourphi* sinthetasq*sintheta + &
- costheta* ((-3.d0* cij_kl(5) - cij_kl(10) - 4.d0* cij_kl(14) - &
- cij_kl(18) + (3.d0* cij_kl(5) + cij_kl(10) - 4.d0* cij_kl(14) + &
- cij_kl(18))* costwotheta)* sinphi + 6.d0* ((cij_kl(4) - cij_kl(9) + &
- cij_kl(20))* costhreephi + (-cij_kl(5) + cij_kl(10) + &
- cij_kl(18))* sinthreephi)* sinthetasq) + costwophi* ((3* cij_kl(6) + &
- 3.d0* cij_kl(11) + 2.d0* (cij_kl(15) + cij_kl(17)))* sintheta - &
- (cij_kl(6) + cij_kl(11) - 2.d0* (cij_kl(15) + &
- cij_kl(17)))* sinthreetheta))
-
- cij_kll(14) = 1.d0/4.d0* (2.d0* cij_kl(13)* (costwotheta + cosfourtheta)* sinphi + &
- 8.d0* costheta*costhetasq* (-2.d0* cij_kl(12) + cij_kl(8)* sinphisq)* sintheta + &
- 4.d0* (cij_kl(4) + cij_kl(20))* cosphisq* (1.d0 + &
- 2.d0* costwotheta)* sinphi* sinthetasq + &
- 4.d0* cij_kl(9)* (1.d0 + 2.d0* costwotheta)* sinphi*sinphisq* sinthetasq + &
- 16.d0* cij_kl(1)* cosphifour* costheta* sintheta*sinthetasq + &
- 4.d0* costheta* (-2.d0* cij_kl(8)* sinphisq + 4.d0* cij_kl(7)* sinphifour + &
- (cij_kl(2) + cij_kl(21))* sintwophisq)* sintheta*sinthetasq + &
- 4.d0* cosphi*cosphisq* sinthetasq* (cij_kl(5) + 2.d0* cij_kl(5)* costwotheta + &
- 4.d0* cij_kl(6)* costheta* sinphi* sintheta) + &
- 2.d0* cosphi* (cosfourtheta* (cij_kl(14) - (cij_kl(10) + cij_kl(18))* sinphisq) + &
- costwotheta* (cij_kl(14) + (cij_kl(10) + cij_kl(18))* sinphisq) + &
- 8.d0* cij_kl(11)* costheta* sinphi*sinphisq* sintheta*sinthetasq) + &
- (cij_kl(3) + cij_kl(16) + cij_kl(19) + (cij_kl(3) - cij_kl(16) + &
- cij_kl(19))* costwophi + (cij_kl(15) + cij_kl(17))* sintwophi)* sinfourtheta)
-
- cij_kll(15) = costwophi* costheta* (-cij_kl(17) + (cij_kl(15) + cij_kl(17))* costhetasq) + &
- 1.d0/16.d0* (-((11.d0* cij_kl(4) + cij_kl(9) + 4.d0* cij_kl(13) - &
- 5.d0* cij_kl(20))* cosphi + (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi - &
- (cij_kl(5) + 11.d0* cij_kl(10) + 4.d0* cij_kl(14) - &
- 5.d0* cij_kl(18))* sinphi + (-cij_kl(5) + cij_kl(10) + &
- cij_kl(18))* sinthreephi)* sintheta + &
- 8.d0* costheta* ((-cij_kl(1) - cij_kl(3) + cij_kl(7) + cij_kl(8) - cij_kl(16) +&
- cij_kl(19) + (cij_kl(1) - cij_kl(3) - &
- cij_kl(7) + cij_kl(8) + cij_kl(16) - cij_kl(19))* costwotheta)* sintwophi +&
- ((cij_kl(6) + cij_kl(11))* costwophi + &
- (cij_kl(6) - cij_kl(11))* cosfourphi + (-cij_kl(1) + cij_kl(2) - cij_kl(7) +&
- cij_kl(21))* sinfourphi)* sinthetasq) +&
- ((cij_kl(4) + 3.d0* cij_kl(9) - 4.d0* cij_kl(13) + cij_kl(20))* cosphi + &
- 3.d0* (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi - &
- (3.d0* cij_kl(5) + cij_kl(10) - 4.d0* cij_kl(14) + cij_kl(18))* sinphi + &
- 3.d0* (-cij_kl(5) + cij_kl(10) + cij_kl(18))* sinthreephi)* sinthreetheta)
-
- cij_kll(16) = 1.d0/4.d0*(cij_kl(1) - cij_kl(2) + cij_kl(7) + cij_kl(16) + &
- cij_kl(19) + cij_kl(21) + 2.d0*(cij_kl(16) - cij_kl(19))*costwophi* costhetasq + &
- (-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(16) + &
- cij_kl(19) - cij_kl(21))*costwotheta - 2.d0* cij_kl(17)* costhetasq* sintwophi + &
- 2.d0* ((-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(21))* cosfourphi + &
- (-cij_kl(6) + cij_kl(11))* sinfourphi)* sinthetasq + ((cij_kl(5) - cij_kl(10) +&
- cij_kl(18))* cosphi + (-cij_kl(5) + cij_kl(10) + cij_kl(18))* costhreephi +&
- (-cij_kl(4) + cij_kl(9) + cij_kl(20))* sinphi - &
- (cij_kl(4) - cij_kl(9) + cij_kl(20))* sinthreephi)* sintwotheta)
-
- cij_kll(17) = 1.d0/8.d0* (4.d0* costwophi* costheta* (cij_kl(6) + cij_kl(11) - &
- 2.d0* cij_kl(15) - (cij_kl(6) + cij_kl(11) - 2.d0* (cij_kl(15) + &
- cij_kl(17)))* costwotheta) - (2.d0* cosphi* (-3.d0* cij_kl(4) +&
- cij_kl(9) + 2.d0* cij_kl(13) + cij_kl(20) + (cij_kl(4) - cij_kl(9) + &
- cij_kl(20))* costwophi) - (cij_kl(5) - 5.d0* cij_kl(10) + &
- 4.d0* cij_kl(14) + 3.d0* cij_kl(18))* sinphi + (-cij_kl(5) + cij_kl(10) + &
- cij_kl(18))* sinthreephi)* sintheta + &
- 8.d0* costheta* ((-cij_kl(1) + cij_kl(3) + cij_kl(7) - cij_kl(8) + &
- (cij_kl(1) - cij_kl(3) - cij_kl(7) + cij_kl(8) + cij_kl(16) - &
- cij_kl(19))* costwotheta)* sintwophi + ((cij_kl(6) - cij_kl(11))* cosfourphi + &
- (-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(21))* sinfourphi)* sinthetasq) +&
- ((cij_kl(4) + 3.d0* cij_kl(9) - 4.d0* cij_kl(13) + cij_kl(20))* cosphi + &
- 3.d0* (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi - &
- (3.d0* cij_kl(5) + cij_kl(10) - 4.d0* cij_kl(14) + cij_kl(18))* sinphi + &
- 3.d0* (-cij_kl(5) + cij_kl(10) + cij_kl(18))* sinthreephi)* sinthreetheta)
-
- cij_kll(18) = 1.d0/2.d0* ((cij_kl(5) - cij_kl(10) + cij_kl(18))* cosphi* costwotheta - &
- (cij_kl(5) - cij_kl(10) - cij_kl(18))* costhreephi* costwotheta - &
- 2.d0* (cij_kl(4) - cij_kl(9) + &
- (cij_kl(4) - cij_kl(9) + cij_kl(20))* costwophi)* costwotheta* sinphi + &
- (cij_kl(1) - cij_kl(2) + cij_kl(7) - cij_kl(16) - cij_kl(19) + cij_kl(21) + &
- (-cij_kl(16) + cij_kl(19))* costwophi + &
- (-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(21))* cosfourphi + &
- cij_kl(17)* sintwophi + &
- (-cij_kl(6) + cij_kl(11))* sinfourphi)* sintwotheta)
-
- cij_kll(19) = 1.d0/4.d0* (cij_kl(16) - cij_kl(16)* costwophi + &
- (-cij_kl(15) + cij_kl(17))* sintwophi + &
- 4.d0* cij_kl(12)* sintwothetasq + &
- 2.d0* (2.d0* cij_kl(1)* cosphifour* sintwothetasq + &
- cosphi*cosphisq* (8.d0* cij_kl(6)* costhetasq* sinphi* sinthetasq + &
- cij_kl(5)* sinfourtheta) + cosphisq* (-cij_kl(3) + cij_kl(19) + (cij_kl(3) +&
- cij_kl(19))* cosfourtheta + (cij_kl(4) + cij_kl(20))* sinphi* sinfourtheta) + &
- sinphi* (cosfourtheta* ((cij_kl(15) + cij_kl(17))* cosphi + &
- cij_kl(16)* sinphi) + (cij_kl(2) + cij_kl(7) - 2.d0* cij_kl(8) + cij_kl(21) + &
- (cij_kl(2) - cij_kl(7) + cij_kl(21))* costwophi)* sinphi* sintwothetasq + &
- (-cij_kl(13) + cij_kl(9)* sinphisq)* sinfourtheta) + &
- cosphi* (8.d0* cij_kl(11)* costhetasq* sinphi*sinphisq* sinthetasq + &
- (-cij_kl(14) + (cij_kl(10) + cij_kl(18))* sinphisq)* sinfourtheta)))
-
- cij_kll(20) = 1.d0/8.d0* (2.d0* cosphi* costheta* (-3.d0* cij_kl(4) - cij_kl(9) + &
- 4.d0* cij_kl(13) + cij_kl(20) + (cij_kl(4) + 3.d0* cij_kl(9) - &
- 4.d0* cij_kl(13) + cij_kl(20))* costwotheta) + &
- (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi* (costheta + &
- 3.d0* costhreetheta) - &
- 2.d0* costheta* (-cij_kl(5) - 3.d0* cij_kl(10) + 4.d0* cij_kl(14) + &
- cij_kl(18) + (3.d0* cij_kl(5) + &
- cij_kl(10) - 4.d0* cij_kl(14) + cij_kl(18))*costwotheta)* sinphi - &
- (cij_kl(5) - cij_kl(10) - cij_kl(18))* &
- (costheta + 3.d0* costhreetheta)* sinthreephi + 8.d0* (cij_kl(6) - &
- cij_kl(11))* cosfourphi* costhetasq* sintheta - 8.d0* (cij_kl(1) - &
- cij_kl(3) - cij_kl(7) + cij_kl(8) + &
- (cij_kl(1) - cij_kl(3) - cij_kl(7) + cij_kl(8) + cij_kl(16) - &
- cij_kl(19))* costwotheta)* sintwophi* sintheta - &
- 8.d0* (cij_kl(1) - cij_kl(2) + cij_kl(7) - &
- cij_kl(21))* costhetasq* sinfourphi* sintheta + &
- 2.d0* costwophi* ((cij_kl(6) + cij_kl(11) - 2.d0* cij_kl(15) + &
- 2.d0* cij_kl(17))* sintheta + &
- (cij_kl(6) + cij_kl(11) - 2.d0* (cij_kl(15) + cij_kl(17)))* sinthreetheta))
-
- cij_kll(21) = 1.d0/4.d0* (cij_kl(1) - cij_kl(2) + cij_kl(7) + cij_kl(16) + &
- cij_kl(19) + cij_kl(21) - 2.d0* (cij_kl(1) - cij_kl(2) + cij_kl(7) - &
- cij_kl(21))* cosfourphi* costhetasq + &
- (cij_kl(1) - cij_kl(2) + cij_kl(7) - cij_kl(16) - cij_kl(19) + &
- cij_kl(21))* costwotheta + &
- 2.d0* (-cij_kl(6) + cij_kl(11))* costhetasq* sinfourphi - &
- 2.d0* ((-cij_kl(16) + cij_kl(19))* costwophi + cij_kl(17)* sintwophi)* sinthetasq - &
- ((cij_kl(5) - cij_kl(10) + cij_kl(18))* cosphi + (-cij_kl(5) + cij_kl(10) +&
- cij_kl(18))* costhreephi + &
- (-cij_kl(4) + cij_kl(9) + cij_kl(20))* sinphi - (cij_kl(4) - cij_kl(9) + &
- cij_kl(20))* sinthreephi)* sintwotheta)
-
- end subroutine rotate_kernels_dble
-
-!-----------------------------------------------------------------------------
-
- subroutine compute_kernels_hessian(ibool_crust_mantle, &
- hess_kl_crust_mantle, &
- accel_crust_mantle,b_accel_crust_mantle, &
- deltat)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- hess_kl_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_accel_crust_mantle
-
- real(kind=CUSTOM_REAL) deltat
-
- ! local parameters
- integer :: i,j,k,ispec,iglob
-
- ! crust_mantle
- do ispec = 1, NSPEC_CRUST_MANTLE
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool_crust_mantle(i,j,k,ispec)
-
- ! approximates hessian
- ! term with adjoint acceleration and backward/reconstructed acceleration
- hess_kl_crust_mantle(i,j,k,ispec) = hess_kl_crust_mantle(i,j,k,ispec) &
- + deltat * (accel_crust_mantle(1,iglob) * b_accel_crust_mantle(1,iglob) &
- + accel_crust_mantle(2,iglob) * b_accel_crust_mantle(2,iglob) &
- + accel_crust_mantle(3,iglob) * b_accel_crust_mantle(3,iglob) )
-
- enddo
- enddo
- enddo
- enddo
-
-
- end subroutine compute_kernels_hessian
-
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_seismograms.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_seismograms.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,377 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- implicit none
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer nrec_local,nrec
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- displ_crust_mantle
-
- double precision, dimension(NDIM,NDIM,nrec) :: nu
-
- double precision, dimension(nrec_local,NGLLX) :: hxir_store
- double precision, dimension(nrec_local,NGLLY) :: hetar_store
- double precision, dimension(nrec_local,NGLLZ) :: hgammar_store
-
- double precision scale_displ
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- integer, dimension(nrec) :: ispec_selected_rec
- integer, dimension(nrec_local) :: number_receiver_global
-
- integer :: seismo_current
- integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
- real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: &
- seismograms
-
- ! local parameters
- double precision :: uxd,uyd,uzd,hlagrange
- integer :: i,j,k,iglob,irec_local,irec
-
- 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
-
- end subroutine compute_seismograms
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- implicit none
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer nrec_local,nrec
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_displ_crust_mantle
-
- double precision, dimension(NDIM,NDIM,nrec) :: nu
-
- double precision, dimension(nrec_local,NGLLX) :: hxir_store
- double precision, dimension(nrec_local,NGLLY) :: hetar_store
- double precision, dimension(nrec_local,NGLLZ) :: hgammar_store
-
- double precision scale_displ
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- integer, dimension(nrec) :: ispec_selected_rec
- integer, dimension(nrec_local) :: number_receiver_global
-
- integer :: seismo_current
- integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
- real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: &
- seismograms
-
- ! local parameters
- double precision :: uxd,uyd,uzd,hlagrange
- integer :: i,j,k,iglob,irec_local,irec
-
- 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(b_displ_crust_mantle(1,iglob))*hlagrange
- uyd = uyd + dble(b_displ_crust_mantle(2,iglob))*hlagrange
- uzd = uzd + dble(b_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
-
- end subroutine compute_seismograms_backward
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- hxir_store,hetar_store,hgammar_store, &
- hpxir_store,hpetar_store,hpgammar_store, &
- tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
- hprime_xx,hprime_yy,hprime_zz, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- moment_der,sloc_der,stshift_der,shdur_der,&
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
- ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
- NSTEP,it,nit_written)
-
- implicit none
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer NSOURCES,nrec_local
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
- eps_trace_over_3_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_crust_mantle
-
- double precision, dimension(NDIM,NDIM,NSOURCES) :: nu_source
- double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
-
- double precision, dimension(nrec_local,NGLLX) :: hxir_store,hpxir_store
- double precision, dimension(nrec_local,NGLLY) :: hetar_store,hpetar_store
- double precision, dimension(nrec_local,NGLLZ) :: hgammar_store,hpgammar_store
-
- double precision, dimension(NSOURCES) :: tshift_cmt,hdur_gaussian
- double precision :: DT,t0
- double precision :: scale_displ, scale_t
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
- 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(NDIM,NDIM,nrec_local) :: moment_der
- real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local) :: sloc_der
- real(kind=CUSTOM_REAL), dimension(nrec_local) :: stshift_der, shdur_der
-
- integer NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
- real(kind=CUSTOM_REAL), dimension(NDIM*NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: &
- seismograms
- real(kind=CUSTOM_REAL) :: deltat
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- integer,dimension(NSOURCES) :: ispec_selected_source
- integer, dimension(nrec_local) :: number_receiver_global
- integer :: NSTEP,it,nit_written
-
- ! local parameters
- double precision :: uxd,uyd,uzd,hlagrange
- double precision :: eps_trace,dxx,dyy,dxy,dxz,dyz
- double precision :: eps_loc(NDIM,NDIM), eps_loc_new(NDIM,NDIM)
- double precision :: stf
- real(kind=CUSTOM_REAL) :: displ_s(NDIM,NGLLX,NGLLY,NGLLZ)
- real(kind=CUSTOM_REAL) :: eps_s(NDIM,NDIM), eps_m_s, &
- eps_m_l_s(NDIM), stf_deltat, Kp_deltat, Hp_deltat
- integer :: i,j,k,iglob,irec_local,irec,ispec
-
- double precision, external :: comp_source_time_function
-
- 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
-
-
- eps_trace = ZERO
- dxx = ZERO
- dyy = ZERO
- dxy = ZERO
- dxz = ZERO
- dyz = ZERO
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- iglob = ibool_crust_mantle(i,j,k,ispec_selected_source(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
-
- eps_trace = eps_trace + dble(eps_trace_over_3_crust_mantle(i,j,k,ispec_selected_source(irec)))*hlagrange
- dxx = dxx + dble(epsilondev_crust_mantle(1,i,j,k,ispec_selected_source(irec)))*hlagrange
- dyy = dyy + dble(epsilondev_crust_mantle(2,i,j,k,ispec_selected_source(irec)))*hlagrange
- dxy = dxy + dble(epsilondev_crust_mantle(3,i,j,k,ispec_selected_source(irec)))*hlagrange
- dxz = dxz + dble(epsilondev_crust_mantle(4,i,j,k,ispec_selected_source(irec)))*hlagrange
- dyz = dyz + dble(epsilondev_crust_mantle(5,i,j,k,ispec_selected_source(irec)))*hlagrange
-
- displ_s(:,i,j,k) = displ_crust_mantle(:,iglob)
-
- enddo
- enddo
- enddo
-
- eps_loc(1,1) = eps_trace + dxx
- eps_loc(2,2) = eps_trace + dyy
- eps_loc(3,3) = eps_trace - dxx - dyy
- eps_loc(1,2) = dxy
- eps_loc(1,3) = dxz
- eps_loc(2,3) = dyz
- eps_loc(2,1) = dxy
- eps_loc(3,1) = dxz
- eps_loc(3,2) = dyz
-
- eps_loc_new(:,:) = eps_loc(:,:)
- ! rotate to the local cartesian coordinates (n-e-z): eps_new=P*eps*P'
- eps_loc_new(:,:) = matmul(matmul(nu_source(:,:,irec),eps_loc(:,:)), transpose(nu_source(:,:,irec)))
-
- ! distinguish between single and double precision for reals
- if (CUSTOM_REAL == SIZE_REAL) then
- seismograms(1,irec_local,it-nit_written) = sngl(eps_loc_new(1,1))
- seismograms(2,irec_local,it-nit_written) = sngl(eps_loc_new(2,2))
- seismograms(3,irec_local,it-nit_written) = sngl(eps_loc_new(3,3))
- seismograms(4,irec_local,it-nit_written) = sngl(eps_loc_new(1,2))
- seismograms(5,irec_local,it-nit_written) = sngl(eps_loc_new(1,3))
- seismograms(6,irec_local,it-nit_written) = sngl(eps_loc_new(2,3))
- seismograms(7:9,irec_local,it-nit_written) = sngl(scale_displ*(nu_source(:,1,irec)*uxd + &
- nu_source(:,2,irec)*uyd + nu_source(:,3,irec)*uzd))
- else
- seismograms(1,irec_local,it-nit_written) = eps_loc_new(1,1)
- seismograms(2,irec_local,it-nit_written) = eps_loc_new(2,2)
- seismograms(3,irec_local,it-nit_written) = eps_loc_new(3,3)
- seismograms(4,irec_local,it-nit_written) = eps_loc_new(1,2)
- seismograms(5,irec_local,it-nit_written) = eps_loc_new(1,3)
- seismograms(6,irec_local,it-nit_written) = eps_loc_new(2,3)
- seismograms(7:9,irec_local,it-nit_written) = scale_displ*(nu_source(:,1,irec)*uxd + &
- nu_source(:,2,irec)*uyd + nu_source(:,3,irec)*uzd)
- endif
-
- ! frechet derviatives of the source
- ispec = ispec_selected_source(irec)
-
- call compute_adj_source_frechet(displ_s,Mxx(irec),Myy(irec),Mzz(irec), &
- Mxy(irec),Mxz(irec),Myz(irec),eps_s,eps_m_s,eps_m_l_s, &
- hxir_store(irec_local,:),hetar_store(irec_local,:),hgammar_store(irec_local,:), &
- hpxir_store(irec_local,:),hpetar_store(irec_local,:),hpgammar_store(irec_local,:), &
- hprime_xx,hprime_yy,hprime_zz, &
- xix_crust_mantle(:,:,:,ispec),xiy_crust_mantle(:,:,:,ispec),xiz_crust_mantle(:,:,:,ispec), &
- etax_crust_mantle(:,:,:,ispec),etay_crust_mantle(:,:,:,ispec),etaz_crust_mantle(:,:,:,ispec), &
- gammax_crust_mantle(:,:,:,ispec),gammay_crust_mantle(:,:,:,ispec),gammaz_crust_mantle(:,:,:,ispec))
-
- stf = comp_source_time_function(dble(NSTEP-it)*DT-t0-tshift_cmt(irec),hdur_gaussian(irec))
- stf_deltat = stf * deltat
-
- moment_der(:,:,irec_local) = moment_der(:,:,irec_local) + eps_s(:,:) * stf_deltat
- sloc_der(:,irec_local) = sloc_der(:,irec_local) + eps_m_l_s(:) * stf_deltat
-
- scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
- Kp_deltat= -1.0d0/sqrt(PI)/hdur_gaussian(irec)*exp(-((dble(NSTEP-it)*DT-t0-tshift_cmt(irec))/hdur_gaussian(irec))**2) &
- * deltat * scale_t
- Hp_deltat= (dble(NSTEP-it)*DT-t0-tshift_cmt(irec))/hdur_gaussian(irec)*Kp_deltat
-
- stshift_der(irec_local) = stshift_der(irec_local) + eps_m_s * Kp_deltat
-
- shdur_der(irec_local) = shdur_der(irec_local) + eps_m_s * Hp_deltat
-
-
- enddo
-
- end subroutine compute_seismograms_adjoint
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_crust_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_crust_mantle.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_crust_mantle.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,354 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_stacey_crust_mantle(ichunk,SIMULATION_TYPE, &
- NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
- veloc_crust_mantle,accel_crust_mantle,b_accel_crust_mantle, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
- wgllwgll_xz,wgllwgll_yz, &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
- normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
- rho_vp_crust_mantle,rho_vs_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
- ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- nimin_crust_mantle,nimax_crust_mantle, &
- njmin_crust_mantle,njmax_crust_mantle, &
- nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
- absorb_xmin_crust_mantle,absorb_xmax_crust_mantle, &
- absorb_ymin_crust_mantle,absorb_ymax_crust_mantle)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer ichunk,SIMULATION_TYPE
- integer NSTEP,it
- logical SAVE_FORWARD
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- veloc_crust_mantle,accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_accel_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
- 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,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
- 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(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: &
- rho_vp_crust_mantle,rho_vs_crust_mantle
-
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
-
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_CM) :: &
- nimin_crust_mantle,nimax_crust_mantle,nkmin_eta_crust_mantle
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_CM) :: &
- njmin_crust_mantle,njmax_crust_mantle,nkmin_xi_crust_mantle
-
- integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
-
- integer reclen_xmin_crust_mantle,reclen_xmax_crust_mantle,&
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle
-
- integer nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nabs_xmin_cm) :: absorb_xmin_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nabs_xmax_cm) :: absorb_xmax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nabs_ymin_cm) :: absorb_ymin_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nabs_ymax_cm) :: absorb_ymax_crust_mantle
-
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: weight
- real(kind=CUSTOM_REAL) :: vn,vx,vy,vz,nx,ny,nz,tx,ty,tz
- integer :: i,j,k,ispec,iglob,ispec2D
- !integer :: reclen1,reclen2
-
- ! note: we use c functions for I/O as they still have a better performance than
- ! fortran, unformatted file I/O. however, using -assume byterecl together with fortran functions
- ! comes very close (only ~ 4 % slower ).
- !
- ! tests with intermediate storages (every 8 step) and/or asynchronious
- ! file access (by process rank modulo 8) showed that the following,
- ! simple approach is still fastest. (assuming that files are accessed on a local scratch disk)
-
-
- ! crust & mantle
-
- ! xmin
- ! if two chunks exclude this face for one of them
- if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
-
- ! reads absorbing boundary values
- if (SIMULATION_TYPE == 3 .and. nspec2D_xmin_crust_mantle > 0) then
- ! note: backward/reconstructed wavefields are read in after the Newmark time scheme in the first time loop
- ! this leads to a corresponding boundary condition at time index NSTEP - (it-1) = NSTEP - it + 1
- call read_abs(0,absorb_xmin_crust_mantle,reclen_xmin_crust_mantle,NSTEP-it+1)
- endif
-
- do ispec2D=1,nspec2D_xmin_crust_mantle
-
- ispec=ibelm_xmin_crust_mantle(ispec2D)
-
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi_crust_mantle(1,ispec2D) == 0 .or. njmin_crust_mantle(1,ispec2D) == 0) cycle
-
- i=1
- do k=nkmin_xi_crust_mantle(1,ispec2D),NGLLZ
- do j=njmin_crust_mantle(1,ispec2D),njmax_crust_mantle(1,ispec2D)
- iglob=ibool_crust_mantle(i,j,k,ispec)
-
- vx=veloc_crust_mantle(1,iglob)
- vy=veloc_crust_mantle(2,iglob)
- vz=veloc_crust_mantle(3,iglob)
-
- nx=normal_xmin_crust_mantle(1,j,k,ispec2D)
- ny=normal_xmin_crust_mantle(2,j,k,ispec2D)
- nz=normal_xmin_crust_mantle(3,j,k,ispec2D)
-
- vn=vx*nx+vy*ny+vz*nz
-
- tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
- ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
- tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
-
- weight=jacobian2D_xmin_crust_mantle(j,k,ispec2D)*wgllwgll_yz(j,k)
-
- accel_crust_mantle(1,iglob)=accel_crust_mantle(1,iglob) - tx*weight
- accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
- accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
-
- if (SIMULATION_TYPE == 3) then
- b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_xmin_crust_mantle(:,j,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- absorb_xmin_crust_mantle(1,j,k,ispec2D) = tx*weight
- absorb_xmin_crust_mantle(2,j,k,ispec2D) = ty*weight
- absorb_xmin_crust_mantle(3,j,k,ispec2D) = tz*weight
- endif
- enddo
- enddo
- enddo
-
- ! writes absorbing boundary values
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmin_crust_mantle > 0 ) then
- call write_abs(0,absorb_xmin_crust_mantle, reclen_xmin_crust_mantle,it)
- endif
- endif
-
- ! xmax
- ! if two chunks exclude this face for one of them
- if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB) then
-
- ! reads absorbing boundary values
- if (SIMULATION_TYPE == 3 .and. nspec2D_xmax_crust_mantle > 0) then
- call read_abs(1,absorb_xmax_crust_mantle,reclen_xmax_crust_mantle,NSTEP-it+1)
- endif
-
- do ispec2D=1,nspec2D_xmax_crust_mantle
-
- ispec=ibelm_xmax_crust_mantle(ispec2D)
-
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi_crust_mantle(2,ispec2D) == 0 .or. njmin_crust_mantle(2,ispec2D) == 0) cycle
-
- i=NGLLX
- do k=nkmin_xi_crust_mantle(2,ispec2D),NGLLZ
- do j=njmin_crust_mantle(2,ispec2D),njmax_crust_mantle(2,ispec2D)
- iglob=ibool_crust_mantle(i,j,k,ispec)
-
- vx=veloc_crust_mantle(1,iglob)
- vy=veloc_crust_mantle(2,iglob)
- vz=veloc_crust_mantle(3,iglob)
-
- nx=normal_xmax_crust_mantle(1,j,k,ispec2D)
- ny=normal_xmax_crust_mantle(2,j,k,ispec2D)
- nz=normal_xmax_crust_mantle(3,j,k,ispec2D)
-
- vn=vx*nx+vy*ny+vz*nz
-
- tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
- ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
- tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
-
- weight=jacobian2D_xmax_crust_mantle(j,k,ispec2D)*wgllwgll_yz(j,k)
-
- accel_crust_mantle(1,iglob)=accel_crust_mantle(1,iglob) - tx*weight
- accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
- accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
-
- if (SIMULATION_TYPE == 3) then
- b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_xmax_crust_mantle(:,j,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- absorb_xmax_crust_mantle(1,j,k,ispec2D) = tx*weight
- absorb_xmax_crust_mantle(2,j,k,ispec2D) = ty*weight
- absorb_xmax_crust_mantle(3,j,k,ispec2D) = tz*weight
- endif
-
- enddo
- enddo
- enddo
-
- ! writes absorbing boundary values
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmax_crust_mantle > 0 ) then
- call write_abs(1,absorb_xmax_crust_mantle,reclen_xmax_crust_mantle,it)
- endif
- endif
-
- ! ymin
-
- ! reads absorbing boundary values
- if (SIMULATION_TYPE == 3 .and. nspec2D_ymin_crust_mantle > 0) then
- call read_abs(2,absorb_ymin_crust_mantle, reclen_ymin_crust_mantle,NSTEP-it+1)
- endif
-
- do ispec2D=1,nspec2D_ymin_crust_mantle
-
- ispec=ibelm_ymin_crust_mantle(ispec2D)
-
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta_crust_mantle(1,ispec2D) == 0 .or. nimin_crust_mantle(1,ispec2D) == 0) cycle
-
- j=1
- do k=nkmin_eta_crust_mantle(1,ispec2D),NGLLZ
- do i=nimin_crust_mantle(1,ispec2D),nimax_crust_mantle(1,ispec2D)
- iglob=ibool_crust_mantle(i,j,k,ispec)
-
- vx=veloc_crust_mantle(1,iglob)
- vy=veloc_crust_mantle(2,iglob)
- vz=veloc_crust_mantle(3,iglob)
-
- nx=normal_ymin_crust_mantle(1,i,k,ispec2D)
- ny=normal_ymin_crust_mantle(2,i,k,ispec2D)
- nz=normal_ymin_crust_mantle(3,i,k,ispec2D)
-
- vn=vx*nx+vy*ny+vz*nz
-
- tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
- ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
- tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
-
- weight=jacobian2D_ymin_crust_mantle(i,k,ispec2D)*wgllwgll_xz(i,k)
-
- accel_crust_mantle(1,iglob)=accel_crust_mantle(1,iglob) - tx*weight
- accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
- accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
-
- if (SIMULATION_TYPE == 3) then
- b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_ymin_crust_mantle(:,i,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- absorb_ymin_crust_mantle(1,i,k,ispec2D) = tx*weight
- absorb_ymin_crust_mantle(2,i,k,ispec2D) = ty*weight
- absorb_ymin_crust_mantle(3,i,k,ispec2D) = tz*weight
- endif
-
- enddo
- enddo
- enddo
-
- ! writes absorbing boundary values
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymin_crust_mantle > 0 ) then
- call write_abs(2,absorb_ymin_crust_mantle,reclen_ymin_crust_mantle,it)
- endif
-
-
-
- ! ymax
-
- ! reads absorbing boundary values
- if (SIMULATION_TYPE == 3 .and. nspec2D_ymax_crust_mantle > 0) then
- call read_abs(3,absorb_ymax_crust_mantle,reclen_ymax_crust_mantle,NSTEP-it+1)
- endif
-
- do ispec2D=1,nspec2D_ymax_crust_mantle
-
- ispec=ibelm_ymax_crust_mantle(ispec2D)
-
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta_crust_mantle(2,ispec2D) == 0 .or. nimin_crust_mantle(2,ispec2D) == 0) cycle
-
- j=NGLLY
- do k=nkmin_eta_crust_mantle(2,ispec2D),NGLLZ
- do i=nimin_crust_mantle(2,ispec2D),nimax_crust_mantle(2,ispec2D)
- iglob=ibool_crust_mantle(i,j,k,ispec)
-
- vx=veloc_crust_mantle(1,iglob)
- vy=veloc_crust_mantle(2,iglob)
- vz=veloc_crust_mantle(3,iglob)
-
- nx=normal_ymax_crust_mantle(1,i,k,ispec2D)
- ny=normal_ymax_crust_mantle(2,i,k,ispec2D)
- nz=normal_ymax_crust_mantle(3,i,k,ispec2D)
-
- vn=vx*nx+vy*ny+vz*nz
-
- tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
- ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
- tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
-
- weight=jacobian2D_ymax_crust_mantle(i,k,ispec2D)*wgllwgll_xz(i,k)
-
- accel_crust_mantle(1,iglob)=accel_crust_mantle(1,iglob) - tx*weight
- accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
- accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
-
- if (SIMULATION_TYPE == 3) then
- b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_ymax_crust_mantle(:,i,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- absorb_ymax_crust_mantle(1,i,k,ispec2D) = tx*weight
- absorb_ymax_crust_mantle(2,i,k,ispec2D) = ty*weight
- absorb_ymax_crust_mantle(3,i,k,ispec2D) = tz*weight
- endif
-
- enddo
- enddo
- enddo
-
- ! writes absorbing boundary values
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymax_crust_mantle > 0 ) then
- call write_abs(3,absorb_ymax_crust_mantle,reclen_ymax_crust_mantle,it)
- endif
-
- end subroutine compute_stacey_crust_mantle
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_outer_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_outer_core.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_outer_core.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
- subroutine compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
- NSTEP,it,ibool_outer_core, &
- veloc_outer_core,accel_outer_core,b_accel_outer_core, &
- vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
- jacobian2D_bottom_outer_core, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
- jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
- ibelm_bottom_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
- ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- nimin_outer_core,nimax_outer_core, &
- njmin_outer_core,njmax_outer_core, &
- nkmin_xi_outer_core,nkmin_eta_outer_core, &
- NSPEC2D_BOTTOM, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_zmin, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- nabs_zmin_oc, &
- nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
- absorb_zmin_outer_core, &
- absorb_xmin_outer_core,absorb_xmax_outer_core, &
- absorb_ymin_outer_core,absorb_ymax_outer_core)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer ichunk,SIMULATION_TYPE
- integer NSTEP,it
- logical SAVE_FORWARD
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
- veloc_outer_core,accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
- b_accel_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_STACEY) :: vp_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- 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,NSPEC2D_BOTTOM_OC) :: &
- jacobian2D_bottom_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
-
-
- integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
-
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_OC) :: &
- nimin_outer_core,nimax_outer_core,nkmin_eta_outer_core
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_OC) :: &
- njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core
-
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_BOTTOM
- integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
-
- integer reclen_zmin,reclen_xmin_outer_core,reclen_xmax_outer_core,&
- reclen_ymin_outer_core,reclen_ymax_outer_core
-
- integer nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc,nabs_zmin_oc
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nabs_xmin_oc) :: absorb_xmin_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nabs_xmax_oc) :: absorb_xmax_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nabs_ymin_oc) :: absorb_ymin_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nabs_ymax_oc) :: absorb_ymax_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,nabs_zmin_oc) :: absorb_zmin_outer_core
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: sn,weight
- !integer :: reclen1,reclen2
- integer :: i,j,k,ispec2D,ispec,iglob
-
- ! note: we use c functions for I/O as they still have a better performance than
- ! fortran, unformatted file I/O. however, using -assume byterecl together with fortran functions
- ! comes very close (only ~ 4 % slower ).
- !
- ! tests with intermediate storages (every 8 step) and/or asynchronious
- ! file access (by process rank modulo 8) showed that the following,
- ! simple approach is still fastest. (assuming that files are accessed on a local scratch disk)
-
- ! xmin
- ! if two chunks exclude this face for one of them
- if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
-
- ! reads absorbing boundary values
- if (SIMULATION_TYPE == 3 .and. nspec2D_xmin_outer_core > 0) then
- ! note: backward/reconstructed wavefields are read in after the Newmark time scheme in the first time loop
- ! this leads to a corresponding boundary condition at time index NSTEP - (it-1) = NSTEP - it + 1
-
- call read_abs(4,absorb_xmin_outer_core,reclen_xmin_outer_core,NSTEP-it+1)
-
-! read(61,rec=NSTEP-it+1) reclen1,absorb_xmin_outer_core,reclen2
-! if (reclen1 /= reclen_xmin_outer_core .or. reclen1 /= reclen2) &
-! call exit_MPI(myrank,'Error reading absorbing contribution absorb_xmin_outer_core')
-
-
- endif
-
- do ispec2D=1,nspec2D_xmin_outer_core
-
- ispec=ibelm_xmin_outer_core(ispec2D)
-
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi_outer_core(1,ispec2D) == 0 .or. njmin_outer_core(1,ispec2D) == 0) cycle
-
- i=1
- do k=nkmin_xi_outer_core(1,ispec2D),NGLLZ
- do j=njmin_outer_core(1,ispec2D),njmax_outer_core(1,ispec2D)
- iglob=ibool_outer_core(i,j,k,ispec)
-
- sn = veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
-
- weight = jacobian2D_xmin_outer_core(j,k,ispec2D)*wgllwgll_yz(j,k)
-
- accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
-
- if (SIMULATION_TYPE == 3) then
- b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_xmin_outer_core(j,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- absorb_xmin_outer_core(j,k,ispec2D) = weight*sn
- endif
- enddo
- enddo
- enddo
-
- ! writes absorbing boundary values
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmin_outer_core > 0 ) then
-
- call write_abs(4,absorb_xmin_outer_core,reclen_xmin_outer_core,it)
-
-! write(61,rec=it) reclen_xmin_outer_core,absorb_xmin_outer_core,reclen_xmin_outer_core
- endif
-
- endif
-
- ! xmax
- ! if two chunks exclude this face for one of them
- if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB) then
-
- if (SIMULATION_TYPE == 3 .and. nspec2D_xmax_outer_core > 0) then
-
- call read_abs(5,absorb_xmax_outer_core,reclen_xmax_outer_core,NSTEP-it+1)
-
-! read(62,rec=NSTEP-it+1) reclen1,absorb_xmax_outer_core,reclen2
-! if (reclen1 /= reclen_xmax_outer_core .or. reclen1 /= reclen2) &
-! call exit_MPI(myrank,'Error reading absorbing contribution absorb_xmax_outer_core')
- endif
-
- do ispec2D=1,nspec2D_xmax_outer_core
-
- ispec=ibelm_xmax_outer_core(ispec2D)
-
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi_outer_core(2,ispec2D) == 0 .or. njmin_outer_core(2,ispec2D) == 0) cycle
-
- i=NGLLX
- do k=nkmin_xi_outer_core(2,ispec2D),NGLLZ
- do j=njmin_outer_core(2,ispec2D),njmax_outer_core(2,ispec2D)
- iglob=ibool_outer_core(i,j,k,ispec)
-
- sn = veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
-
- weight = jacobian2D_xmax_outer_core(j,k,ispec2D)*wgllwgll_yz(j,k)
-
- accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
-
- if (SIMULATION_TYPE == 3) then
- b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_xmax_outer_core(j,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- absorb_xmax_outer_core(j,k,ispec2D) = weight*sn
- endif
-
- enddo
- enddo
- enddo
-
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmax_outer_core > 0 ) then
- call write_abs(5,absorb_xmax_outer_core,reclen_xmax_outer_core,it)
-
-! write(62,rec=it) reclen_xmax_outer_core,absorb_xmax_outer_core,reclen_xmax_outer_core
- endif
-
- endif
-
- ! ymin
- if (SIMULATION_TYPE == 3 .and. nspec2D_ymin_outer_core > 0) then
-
- call read_abs(6,absorb_ymin_outer_core,reclen_ymin_outer_core,NSTEP-it+1)
-
-! read(63,rec=NSTEP-it+1) reclen1,absorb_ymin_outer_core,reclen2
-! if (reclen1 /= reclen_ymin_outer_core .or. reclen1 /= reclen2) &
-! call exit_MPI(myrank,'Error reading absorbing contribution absorb_ymin_outer_core')
- endif
-
- do ispec2D=1,nspec2D_ymin_outer_core
-
- ispec=ibelm_ymin_outer_core(ispec2D)
-
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta_outer_core(1,ispec2D) == 0 .or. nimin_outer_core(1,ispec2D) == 0) cycle
-
- j=1
- do k=nkmin_eta_outer_core(1,ispec2D),NGLLZ
- do i=nimin_outer_core(1,ispec2D),nimax_outer_core(1,ispec2D)
- iglob=ibool_outer_core(i,j,k,ispec)
-
- sn = veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
-
- weight=jacobian2D_ymin_outer_core(i,k,ispec2D)*wgllwgll_xz(i,k)
-
- accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
-
- if (SIMULATION_TYPE == 3) then
- b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_ymin_outer_core(i,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- absorb_ymin_outer_core(i,k,ispec2D) = weight*sn
- endif
-
- enddo
- enddo
- enddo
-
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymin_outer_core > 0 ) then
- call write_abs(6,absorb_ymin_outer_core,reclen_ymin_outer_core,it)
-
-! write(63,rec=it) reclen_ymin_outer_core,absorb_ymin_outer_core,reclen_ymin_outer_core
- endif
-
- ! ymax
- if (SIMULATION_TYPE == 3 .and. nspec2D_ymax_outer_core > 0) then
-
- call read_abs(7,absorb_ymax_outer_core,reclen_ymax_outer_core,NSTEP-it+1)
-
-! read(64,rec=NSTEP-it+1) reclen1,absorb_ymax_outer_core,reclen2
-! if (reclen1 /= reclen_ymax_outer_core .or. reclen1 /= reclen2) &
-! call exit_MPI(myrank,'Error reading absorbing contribution absorb_ymax_outer_core')
- endif
- do ispec2D=1,nspec2D_ymax_outer_core
-
- ispec=ibelm_ymax_outer_core(ispec2D)
-
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta_outer_core(2,ispec2D) == 0 .or. nimin_outer_core(2,ispec2D) == 0) cycle
-
- j=NGLLY
- do k=nkmin_eta_outer_core(2,ispec2D),NGLLZ
- do i=nimin_outer_core(2,ispec2D),nimax_outer_core(2,ispec2D)
- iglob=ibool_outer_core(i,j,k,ispec)
-
- sn = veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
-
- weight=jacobian2D_ymax_outer_core(i,k,ispec2D)*wgllwgll_xz(i,k)
-
- accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
-
- if (SIMULATION_TYPE == 3) then
- b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_ymax_outer_core(i,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- absorb_ymax_outer_core(i,k,ispec2D) = weight*sn
- endif
-
- enddo
- enddo
- enddo
-
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymax_outer_core > 0 ) then
- call write_abs(7,absorb_ymax_outer_core,reclen_ymax_outer_core,it)
-
-! write(64,rec=it) reclen_ymax_outer_core,absorb_ymax_outer_core,reclen_ymax_outer_core
- endif
-
- ! for surface elements exactly on the ICB
- if (SIMULATION_TYPE == 3 .and. NSPEC2D_BOTTOM(IREGION_OUTER_CORE)> 0) then
-
- call read_abs(8,absorb_zmin_outer_core,reclen_zmin,NSTEP-it+1)
-
-! read(65,rec=NSTEP-it+1) reclen1,absorb_zmin_outer_core,reclen2
-! if (reclen1 /= reclen_zmin .or. reclen1 /= reclen2) &
-! call exit_MPI(myrank,'Error reading absorbing contribution absorb_zmin_outer_core')
- endif
-
- do ispec2D = 1,NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
-
- ispec = ibelm_bottom_outer_core(ispec2D)
-
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool_outer_core(i,j,k,ispec)
-
- sn = veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
-
- weight = jacobian2D_bottom_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
-
- accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
-
- if (SIMULATION_TYPE == 3) then
- b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_zmin_outer_core(i,j,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- absorb_zmin_outer_core(i,j,ispec2D) = weight*sn
- endif
-
- enddo
- enddo
- enddo
-
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 ) then
- call write_abs(8,absorb_zmin_outer_core,reclen_zmin,it)
-
-! write(65,rec=it) reclen_zmin,absorb_zmin_outer_core,reclen_zmin
- endif
-
- end subroutine compute_stacey_outer_core
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/config.h.in
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/config.h.in 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/config.h.in 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,33 +0,0 @@
-/* config.h.in. Generated from configure.ac by autoheader. */
-
-/* Define to dummy `main' function (if any) required to link to the Fortran
- libraries. */
-#undef FC_DUMMY_MAIN
-
-/* Define if F77 and FC dummy `main' functions are identical. */
-#undef FC_DUMMY_MAIN_EQ_F77
-
-/* Define to a macro mangling the given C identifier (in lower and upper
- case), which must not contain underscores, for linking with Fortran. */
-#undef FC_FUNC
-
-/* As FC_FUNC, but for C identifiers containing underscores. */
-#undef FC_FUNC_
-
-/* Define to the address where bug reports for this package should be sent. */
-#undef PACKAGE_BUGREPORT
-
-/* Define to the full name of this package. */
-#undef PACKAGE_NAME
-
-/* Define to the full name and version of this package. */
-#undef PACKAGE_STRING
-
-/* Define to the one symbol short name of this package. */
-#undef PACKAGE_TARNAME
-
-/* Define to the version of this package. */
-#undef PACKAGE_VERSION
-
-/* Uncomment to select optimized file i/o for regional simulations */
-/* #define USE_MAP_FUNCTION */
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/constants.h.in
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/constants.h.in 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/constants.h.in 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,582 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 0
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! March 2010
-!
-! 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.
-!
-!=====================================================================
-
-! @configure_input@
-
-!
-!--- user can modify parameters below
-!
-
-!
-! 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 = @CUSTOM_REAL@
-
-! this for non blocking assembly
- logical, parameter :: USE_NONBLOCKING_COMMS = .true.
- integer, parameter :: ELEMENTS_NONBLOCKING_CM_IC = 1500
- integer, parameter :: ELEMENTS_NONBLOCKING_OC = 3000
-
-! if files on a local path on each node are also seen as global with same path
-! set to .true. typically on a shared-memory machine with a common file system
-! set to .false. typically on a cluster of nodes with local disks
-! if running on a cluster of nodes with local disks, also customize global path
-! to local files in create_serial_name_database.f90 ("20 format ...")
-! Flag is used only when one checks the mesh with the serial codes
-! ("xcheck_buffers_1D" etc.), ignore it if you do not plan to use them
- logical, parameter :: LOCAL_PATH_IS_ALSO_GLOBAL = . at LOCAL_PATH_IS_ALSO_GLOBAL@.
-
-! input, output and main MPI I/O files
- integer, parameter :: ISTANDARD_OUTPUT = 6
- integer, parameter :: IIN = 40,IOUT = 41,IOUT_SAC = 903
- integer, parameter :: IIN_NOISE = 43,IOUT_NOISE = 44
-! 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
-! I/O unit for source and receiver vtk file
- integer, parameter :: IOVTK = 98
-
-
-! 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'
-
-!!--- ETOPO1 1-minute model, implemented now, but data file must be created first
-!! size of topography and bathymetry file
-! integer, parameter :: NX_BATHY = 21600,NY_BATHY = 10800
-!! resolution of topography file in minutes
-! integer, parameter :: RESOLUTION_TOPO_FILE = 1
-!! pathname of the topography file (un-smoothed)
-! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/ETOPO1.xyz'
-
-! Use GLL points to capture TOPOGRAPHY and ELLIPTICITY (experimental feature)
- logical,parameter :: USE_GLL = .false.
-
-! 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
-
-!-- crustal models
- integer, parameter :: ICRUST_CRUST2 = 1
- integer, parameter :: ICRUST_CRUSTMAPS = 2
-
-! increase smoothing for critical regions (increases mesh stability)
- logical, parameter :: SMOOTH_CRUST = .true.
-
-! use sedimentary layers in crustal model
- logical, parameter :: INCLUDE_SEDIMENTS_CRUST = .true.
- double precision, parameter :: MINIMUM_SEDIMENT_THICKNESS = 2.d0 ! minimim thickness in km
-
-!-- uncomment for using Crust2.0 (used when CRUSTAL flag is set for simulation)
- integer, parameter :: ITYPE_CRUSTAL_MODEL = ICRUST_CRUST2
-!!-- uncomment for using General Crustmaps instead
-!! integer, parameter :: ITYPE_CRUSTAL_MODEL = ICRUST_CRUSTMAPS
-
-! 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
-
-! use a force source located exactly at a grid point instead of a CMTSOLUTION source
-! this can be useful e.g. for asteroid impact simulations
-! in which the source is a vertical force, normal force, impact etc.
- logical, parameter :: USE_FORCE_POINT_SOURCE = .false.
- double precision, parameter :: FACTOR_FORCE_SOURCE = 1.d15
- integer, parameter :: COMPONENT_FORCE_SOURCE = 3 ! takes direction in comp E/N/Z = 1/2/3
-
-! use this t0 as earliest starting time rather than the automatically calculated one
-! (must be positive and bigger than the automatically one to be effective;
-! simulation will start at t = - t0)
- double precision, parameter :: USER_T0 = 0.0d0
-
-! 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.
-
-! output only transverse isotropic kernels (alpha_v,alpha_h,beta_v,beta_h,eta,rho)
-! rather than fully anisotropic kernels in case ANISOTROPIC_KL is set to .true.
- logical, parameter :: SAVE_TRANSVERSE_KL = .false.
-
-! output approximate hessian in crust mantle region
- logical, parameter :: APPROXIMATE_HESS_KL = .false.
-
-! output kernel mask to zero out source region
- logical,parameter :: SAVE_SOURCE_MASK = .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.
-
-! flag to turn off the conversion of geographic to geocentric coordinates for
-! the seismic source and the stations; i.e. assume a perfect sphere, which
-! can be useful for benchmarks of a spherical Earth with fictitious sources and stations
- logical, parameter :: ASSUME_PERFECT_SPHERE = .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
-
-! Deville routines optimized for NGLLX = NGLLY = NGLLZ = 5
- integer, parameter :: m1 = NGLLX, m2 = NGLLX * NGLLY
-
-! 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_1DREF = 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
- integer, parameter :: THREE_D_MODEL_PPM = 9 ! format for point profile models
- integer, parameter :: THREE_D_MODEL_GLL = 10 ! format for iterations with GLL mesh
- integer, parameter :: THREE_D_MODEL_S40RTS = 11
- integer, parameter :: THREE_D_MODEL_GAPP2 = 12
-
-! 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, was 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, was 4
-
-! number of slaves per corner
- integer, parameter :: NUMSLAVES = 2
-
-! 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 = 136
-
-! 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 = 20,NS_20 = 20,NS_40 = 40, ND = 1
-
-! heterogen_mantle_model_constants
- integer, parameter :: N_R = 256,N_THETA = 256,N_PHI = 256
-
-! 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
-
-!QRFSI12 constants
- integer,parameter :: NKQ=8,MAXL_Q=12
- integer,parameter :: NSQ=(MAXL_Q+1)**2,NDEPTHS_REFQ=913
-
-! 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
-
-! General Crustmaps parameters
- integer, parameter :: CRUSTMAP_RESOLUTION = 4 !means 1/4 degrees
- integer, parameter :: NLAYERS_CRUSTMAP = 5
-
-!!!!!!!!!!!!!! end of parameters added for the thread-safe version of the code
-
-! for the stretching of crustal elements in the case of 3D models
-! (values are chosen for 3D models to have RMOHO_FICTICIOUS at 35 km
-! and RMIDDLE_CRUST to become 15 km with stretching function stretch_tab)
- double precision, parameter :: MAX_RATIO_CRUST_STRETCHING = 0.75d0
- double precision, parameter :: RMOHO_STRETCH_ADJUSTEMENT = 5000.d0 ! moho up to 35km
- double precision, parameter :: R80_STRETCH_ADJUSTEMENT = -40000.d0 ! r80 down to 120km
-
-! adapted regional moho stretching
-! 1 chunk simulations, 3-layer crust
- logical, parameter :: REGIONAL_MOHO_MESH = .false.
- logical, parameter :: REGIONAL_MOHO_MESH_EUROPE = .false. ! used only for fixing time step
- logical, parameter :: REGIONAL_MOHO_MESH_ASIA = .false. ! used only for fixing time step
- logical, parameter :: HONOR_DEEP_MOHO = .false.
-! uncomment for e.g. Europe case, where deep moho is rare
-!! double precision, parameter :: RMOHO_STRETCH_ADJUSTEMENT = -15000.d0 ! moho mesh boundary down to 55km
-! uncomment for deep moho cases, e.g. Asia case (Himalayan moho)
-!! double precision, parameter :: RMOHO_STRETCH_ADJUSTEMENT = -20000.d0 ! moho mesh boundary down to 60km
-
-
-! 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 inflate the central cube (set to 0.d0 for a non-inflated cube)
- double precision, parameter :: CENTRAL_CUBE_INFLATE_FACTOR = 0.41d0
-
-! 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/convert_time.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/convert_time.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/convert_time.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,235 +0,0 @@
-
-! open-source subroutines taken from the World Ocean Circulation Experiment (WOCE)
-! web site at http://www.coaps.fsu.edu/woce/html/wcdtools.htm
-
-! converted to Fortran90 by Dimitri Komatitsch,
-! University of Pau, France, January 2008.
-! Also converted "convtime" from a function to a subroutine.
-! Also used a more complete test to detect leap years (the original version was incomplete).
-
- subroutine convtime(timestamp,yr,mon,day,hr,min)
-
-! Originally written by Shawn Smith (smith AT coaps.fsu.edu)
-! Updated Spring 1999 for Y2K compliance by Anthony Arguez (anthony AT coaps.fsu.edu).
-
-! This subroutine will convert a given year, month, day, hour, and
-! minutes to a minutes from 01 Jan 1980 00:00 time stamp.
-
- implicit none
-
- integer, intent(out) :: timestamp
-
- integer, intent(in) :: yr,mon,day,hr,min
-
- integer :: year(1980:2020),month(12),leap_mon(12)
-
- integer :: min_day,min_hr
-
-! function to determine if year is a leap year
- logical, external :: is_leap_year
-
- data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
- 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
- 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
- 9993600, 10519200, 11046240, 11571840, 12097440, &
- 12623040, 13150080, 13675680, 14201280, 14726880, &
- 15253920, 15779520, 16305120, 16830720, 17357760, &
- 17883360, 18408960, 18934560, 19461600, 19987200, &
- 20512800, 21038400/
-
- data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
- 305280, 349920, 393120, 437760, 480960/
-
- data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
- 306720, 351360, 394560, 439200, 482400/
-
- data min_day, min_hr /1440, 60/
-
-! Test values to see if they fit valid ranges
- if (yr < 1980 .or. yr > 2020) stop 'Error in convtime: year out of range (1980-2020)'
-
- if (mon < 1 .or. mon > 12) stop 'Error in convtime: month out of range (1-12)'
-
- if (mon == 2) then
- if (is_leap_year(yr) .and. (day < 1 .or. day > 29)) then
- stop 'Error in convtime: February day out of range (1-29)'
- elseif (.not. is_leap_year(yr) .and. (day < 1 .or. day > 28)) then
- stop 'Error in convtime: February day out of range (1-28)'
- endif
- elseif (mon == 4 .or. mon == 6 .or. mon == 9 .or. mon == 11) then
- if (day < 1 .or. day > 30) stop 'Error in convtime: day out of range (1-30)'
- else
- if (day < 1 .or. day > 31) stop 'Error in convtime: day out of range (1-31)'
- endif
-
- if (hr < 0 .or. hr > 23) stop 'Error in convtime: hour out of range (0-23)'
-
- if (min < 0 .or. min > 60) stop 'Error in convtime: minute out of range (0-60)'
-
-! convert time (test if leap year)
- if (is_leap_year(yr)) then
- timestamp = year(yr)+leap_mon(mon)+((day-1)*min_day)+(hr*min_hr)+min
- else
- timestamp = year(yr)+month(mon)+((day-1)*min_day)+(hr*min_hr)+min
- endif
-
- end subroutine convtime
-
-!
-!----
-!
-
- subroutine invtime(timestamp,yr,mon,day,hr,min)
-
-! This subroutine will convert a minutes timestamp to a year/month
-! date. Based on the function convtime by Shawn Smith (COAPS).
-!
-! Written the spring of 1995, several iterations.
-! James N. Stricherz (stricherz AT coaps.fsu.edu)
-!
-! Updated for Y2K compliance in July 1999.
-! Shyam Lakshmin (lakshmin AT coaps.fsu.edu)
-!
-! This code returns correct results for the range of 01 Jan 1980 00:00
-! thru 31 Dec 2020 23:59. I know it does, because I tried each minute of that range.
-
- implicit none
-
- integer, intent(in) :: timestamp
-
- integer, intent(out) :: yr,mon,day,hr,min
-
- integer :: year(1980:2021),month(13),leap_mon(13)
-
- integer :: min_day,min_hr,itime,tmon,ttime,thour,iyr,imon,iday,ihour
-
-! function to determine if year is a leap year
- logical, external :: is_leap_year
-
- data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
- 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
- 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
- 9993600, 10519200, 11046240, 11571840, 12097440, &
- 12623040, 13150080, 13675680, 14201280, 14726880, &
- 15253920, 15779520, 16305120, 16830720, 17357760, &
- 17883360, 18408960, 18934560, 19461600, 19987200, &
- 20512800, 21038400, 21565440/
-
- data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
- 305280, 349920, 393120, 437760, 480960,525600/
-
- data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
- 306720, 351360, 394560, 439200, 482400,527040/
-
- data min_day, min_hr /1440, 60/
-
-! ok, let us invert the effects of the years: subtract off the
-! number of minutes per year until it goes negative
-! iyr then gives the year that the time (in minutes) occurs
- if (timestamp >= year(2021)) stop 'year too high in invtime'
-
- iyr=1979
- itime=timestamp
-
- 10 iyr=iyr+1
- ttime=itime-year(iyr)
- if (ttime <= 0) then
- if (iyr == 1980) iyr=iyr+1
- iyr=iyr-1
- itime=itime-year(iyr)
- else
- goto 10
- endif
-
-! assign the return variable
- yr=iyr
-
-! ok, the remaining time is less than one full year, so convert
-! by the same method as above into months
- imon=0
-
-! if not leap year
- if (.not. is_leap_year(iyr)) then
-
-! increment the month, and subtract off the minutes from the
-! remaining time for a non-leap year
- 20 imon=imon+1
- tmon=itime-month(imon)
- if (tmon > 0) then
- goto 20
- else if (tmon < 0) then
- imon=imon-1
- itime=itime-month(imon)
- else
- if (imon > 12) then
- imon=imon-12
- yr=yr+1
- endif
- mon=imon
- day=1
- hr=0
- min=0
- return
- endif
-
-! if leap year
- else
-
-! same thing, same code, but for a leap year
- 30 imon=imon+1
- tmon=itime-leap_mon(imon)
- if (tmon > 0) then
- goto 30
- elseif (tmon < 0) then
- imon=imon-1
- itime=itime-month(imon)
- else
- if (imon > 12) then
- imon=imon-12
- yr=yr+1
- endif
- mon=imon
- day=1
- hr=0
- min=0
- return
- endif
- endif
-
-! assign the return variable
- mon=imon
-
-! any remaining minutes will belong to day/hour/minutes
-! ok, let us get the days
- iday=0
- 40 iday=iday+1
- ttime=itime-min_day
- if (ttime >= 0) then
- itime=ttime
- goto 40
- endif
-
-! assign the return variable
- if (is_leap_year(iyr) .and. mon > 2) then
- day=iday-1
- else
- day=iday
- endif
-
-! pick off the hours of the days...remember, hours can be 0, so we start at -1
- ihour=-1
- 50 ihour=ihour+1
- thour=itime-min_hr
- if (thour >= 0) then
- itime=thour
- goto 50
- endif
-
-! assign the return variables
- hr=ihour
-
-! the remainder at this point is the minutes, so return them directly
- min=itime
-
- end subroutine invtime
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/convolve_source_timefunction.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/convolve_source_timefunction.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/convolve_source_timefunction.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- 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/count_number_of_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/count_number_of_sources.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/count_number_of_sources.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/create_central_cube.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,275 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine create_central_cube(myrank,ichunk,ispec,iaddx,iaddy,iaddz, &
- nspec,NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,R_CENTRAL_CUBE, &
- iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,ratio_divide_central_cube, &
- iMPIcut_xi,iMPIcut_eta,iboun, &
- idoubling,iregion_code,xstore,ystore,zstore, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME,&
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- shape3D,rmin,rmax,rhostore,dvpstore,&
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore,nspec_actually, &
- 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
- rho_vp,rho_vs,ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS,xigll,yigll,zigll)
-
-! creates the inner core cube of the mesh
-
- use meshfem3D_models_par
-
- implicit none
-
- integer :: ratio_divide_central_cube
-
-! correct number of spectral elements in each block depending on chunk type
- integer nspec,nspec_stacey
-
- integer NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
-
- integer NPROC_XI,NPROC_ETA
-
- double precision R_CENTRAL_CUBE,RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,&
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,RMOHO_FICTITIOUS_IN_MESHER
-
-! 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)
-
-! 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 xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
-
-! 3D shape functions and their derivatives
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
-
- integer idoubling(nspec)
-
-! for model density and anisotropy
- integer nspec_ani
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
-
-! 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
-
-! boundary locator
- logical iboun(6,nspec)
-
-! arrays with mesh parameters
- integer nspec_actually
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
-! proc numbers for MPI
- integer myrank
-
-
-! MPI cut-planes parameters along xi and along eta
- logical, dimension(2,nspec) :: iMPIcut_xi,iMPIcut_eta
-
-! Stacey, indices for Clayton-Engquist absorbing conditions
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
-
- integer ispec
- integer iproc_xi,iproc_eta,ichunk
-
-! attenuation
- integer nspec_att
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
- double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
- double precision, dimension(N_SLS) :: tau_s
- double precision T_c_source
-
- logical :: ACTUALLY_STORE_ARRAYS,ABSORBING_CONDITIONS
-
- !local parameters
- double precision, dimension(NGNOD) :: xelm,yelm,zelm
- ! parameters needed to store the radii of the grid points in the spherically symmetric Earth
- double precision :: rmin,rmax
- ! to define the central cube in the inner core
- double precision :: radius_cube
- double precision :: xgrid_central_cube,ygrid_central_cube,zgrid_central_cube
- integer ix,iy,iz,ia
- integer nx_central_cube,ny_central_cube,nz_central_cube
- ! the height at which the central cube is cut
- integer :: nz_inf_limit
-
-
-
- ! 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,myrank,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore,nspec_actually, &
- 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
- rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
- xigll,yigll,zigll)
- enddo
- enddo
- enddo
-
- end subroutine create_central_cube
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube_buffers.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube_buffers.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!
-!--- create 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/create_chunk_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_chunk_buffers.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_chunk_buffers.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,981 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! subroutine 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)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
- 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
- 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 NGLOB2DMAX_XY
- 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)
- double precision xread1D(NGLOB1D_RADIAL_MAX)
- double precision yread1D(NGLOB1D_RADIAL_MAX)
- double precision zread1D(NGLOB1D_RADIAL_MAX)
- double precision xdummy,ydummy,zdummy
- integer ipoin1D
-
-! 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, njunk
- 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,filename_in,filename_out
-
-! 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
-
- ! initializes counters
- NUM_FACES = 0
- NUM_MSG_TYPES = 0
- iproc_xi_send = 0
- iproc_xi_receive = 0
- iproc_eta_send = 0
- iproc_eta_receive = 0
- iproc_edge_send = 0
- iproc_edge_receive = 0
- iedge = 0
- ichunk_receive = 0
- ichunk_send = 0
-
-! 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
-
-! define maximum size for message buffers
- NGLOB2DMAX_XY = max(NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX)
-
-! 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
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='unknown')
-
- endif
-
-! 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
- 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
- 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
-
-! create the name of the database for each slice
- call create_name_database(prname,iproc,iregion_code,LOCAL_PATH)
-
-! open file for 2D buffer
- 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
-
- open(unit=IIN,file=prname(1:len_trim(prname))//'boundary.bin',status='old',action='read',form='unformatted')
- read(IIN) nspec2D_xmin
- read(IIN) nspec2D_xmax
- read(IIN) nspec2D_ymin
- read(IIN) nspec2D_ymax
- read(IIN) njunk
- read(IIN) njunk
-
- read(IIN) ibelm_xmin
- read(IIN) ibelm_xmax
- read(IIN) ibelm_ymin
- read(IIN) ibelm_ymax
- close(IIN)
-
-! read 1D buffers to remove corner points
- open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
- read(IIN,*) ibool1D_leftxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
- enddo
- close(IIN)
-
- open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
- read(IIN,*) ibool1D_rightxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
- enddo
- close(IIN)
-
- open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
- read(IIN,*) ibool1D_leftxi_righteta(ipoin1D),xdummy,ydummy,zdummy
- enddo
- close(IIN)
-
- open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
- read(IIN,*) ibool1D_rightxi_righteta(ipoin1D),xdummy,ydummy,zdummy
- enddo
- 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(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
-
- 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(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
-
- 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(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
-
- 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(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
-
- 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
- write(IOUT_BUFFERS,*) npoin2D
- do ipoin2D = 1,npoin2D
- write(IOUT_BUFFERS,*) ibool_selected(ipoin2D), &
- xstore_selected(ipoin2D),ystore_selected(ipoin2D),zstore_selected(ipoin2D)
- enddo
-
- 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
-
- 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
-
-!
-!---- 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
-
- 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
-
-! pick the correct 1D buffer
-! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
- if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
- filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt'
- NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,1)
- else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
- filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt'
- NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,4)
- else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
- filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt'
- NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,2)
- else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
- filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt'
- NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,3)
- else
- call exit_MPI(myrank,'incorrect corner coordinates')
- endif
-
-! read 1D buffer for corner
- open(unit=IIN,file=filename_in,status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL
- read(IIN,*) ibool1D(ipoin1D), &
- xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
- enddo
- 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,xread1D,yread1D,zread1D, &
- ibool1D,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-! check that no duplicates have been found
- if(nglob /= NGLOB1D_RADIAL) call exit_MPI(myrank,'duplicates found for corners')
-
-! write file with 1D buffer for corner
- open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
- write(IOUT_BUFFERS,*) NGLOB1D_RADIAL
- do ipoin1D = 1,NGLOB1D_RADIAL
- write(IOUT_BUFFERS,*) ibool1D(ipoin1D), &
- xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
- enddo
- close(IOUT_BUFFERS)
-
-! end of section done only if right processor for MPI
- endif
-
- enddo
-
- enddo
-
- 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/create_doubling_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_doubling_elements.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_doubling_elements.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine create_doubling_elements(myrank,ilayer,ichunk,ispec,ipass, &
- ifirst_region,ilast_region,iregion_code, &
- nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
- NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- ner,ratio_sampling_array,r_top,r_bottom, &
- xstore,ystore,zstore,xigll,yigll,zigll, &
- shape3D,dershape2D_bottom, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- rmin,rmax,r_moho,r_400,r_670, &
- rhostore,dvpstore,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, &
- nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore,&
- nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
- ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
- nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
- rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB,ACTUALLY_STORE_ARRAYS, &
- NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
- 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, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta)
-
-
-! adds doubling elements to the different regions of the mesh
-
- use meshfem3D_models_par
-
- implicit none
-
- integer :: myrank,ilayer,ichunk,ispec,ipass,ifirst_region,ilast_region
- ! code for the four regions of the mesh
- integer iregion_code
- ! correct number of spectral elements in each block depending on chunk type
- integer nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS
- integer NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
-
-! 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)
-
-! Gauss-Lobatto-Legendre points and weights of integration
- double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
-
-! 3D shape functions and their derivatives
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
-
-! 2D shape functions and their derivatives
- double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
-
- logical INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
-
- double precision RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
-
-! parameters needed to store the radii of the grid points in the spherically symmetric Earth
- double precision rmin,rmax
- double precision r_moho,r_400,r_670
-
-! for model density and anisotropy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
-
-! the 21 coefficients for an anisotropic medium in reduced notation
- integer nspec_ani
- 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
-
-! arrays with mesh parameters
- integer nspec_actually
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
-! Stacey, indices for Clayton-Engquist absorbing conditions
- integer nspec_stacey
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
-
-! boundary locator
- logical iboun(6,nspec)
-
-! MPI cut-planes parameters along xi and along eta
- logical, dimension(2,nspec) :: iMPIcut_xi,iMPIcut_eta
-
- double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
- integer iproc_xi,iproc_eta
-
-! attenuation
- integer nspec_att
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
- double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
- double precision, dimension(N_SLS) :: tau_s
- double precision T_c_source
-
-! rotation matrix from Euler angles
- double precision, dimension(NDIM,NDIM) :: rotation_matrix
-
- integer idoubling(nspec)
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- logical :: USE_ONE_LAYER_SB
- logical :: ACTUALLY_STORE_ARRAYS
-
-! Boundary Mesh
- integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
- integer ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO)
- integer ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400)
- integer ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670)
- real(kind=CUSTOM_REAL) normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO)
- real(kind=CUSTOM_REAL) normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400)
- real(kind=CUSTOM_REAL) normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670)
- real(kind=CUSTOM_REAL) jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO)
- real(kind=CUSTOM_REAL) jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400)
- real(kind=CUSTOM_REAL) jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670)
-
- integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot
-
- integer :: offset_proc_xi,offset_proc_eta
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
-
- ! local parameters
- double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
- double precision, dimension(NGNOD) :: offset_x,offset_y,offset_z
- double precision, dimension(NGNOD) :: xelm,yelm,zelm
- double precision :: r1,r2,r3,r4,r5,r6,r7,r8
- ! mesh doubling superbrick
- integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
- integer :: ix_elem,iy_elem,iz_elem,ignod,ispec_superbrick,case_xi,case_eta
- integer :: step_mult,subblock_num
- integer :: nspec_sb
- logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
- logical :: is_superbrick
-
-
-! 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 (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
- 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,myrank,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore,nspec_actually, &
- 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
- rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
- xigll,yigll,zigll)
-
- ! 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
-
- end subroutine create_doubling_elements
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/create_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_header_file.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_header_file.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,242 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! create 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, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION,CASE_3D, &
- ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
-
- 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,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
-
-
-! 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,OCEANS,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, &
- SIMULATION_TYPE,SAVE_FORWARD,MOVIE_VOLUME)
-
- print *
- print *,'edit file OUTPUT_FILES/values_from_mesher.h to see'
- print *,'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 *,'time-stepping of the solver will be: ',DT
- print *
- if(MOVIE_SURFACE .or. MOVIE_VOLUME) then
- print *,'MOVIE_VOLUME:',MOVIE_VOLUME
- print *,'MOVIE_SURFACE:',MOVIE_SURFACE
- print *,'Saving movie frames every',NTSTEP_BETWEEN_FRAMES
- endif
- 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% or 90%'
- print *,' of the memory installed per core)'
- 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/create_mass_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_mass_matrices.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_mass_matrices.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,228 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine create_mass_matrices(myrank,nspec,idoubling,wxgll,wygll,wzgll,ibool, &
- nspec_actually,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- iregion_code,nglob,rmass,rhostore,kappavstore, &
- nglob_oceans,rmass_ocean_load,NSPEC2D_TOP,ibelm_top,jacobian2D_top, &
- xstore,ystore,zstore,RHO_OCEANS)
-
-! creates rmass and rmass_ocean_load
-
- use meshfem3D_models_par
-
- implicit none
-
- integer myrank,nspec
-
- integer idoubling(nspec)
-
- double precision wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer nspec_actually
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
- integer iregion_code
-
- ! mass matrix
- integer nglob
- real(kind=CUSTOM_REAL), dimension(nglob) :: rmass
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,kappavstore
-
- ! ocean mass matrix
- integer nglob_oceans
- real(kind=CUSTOM_REAL), dimension(nglob_oceans) :: rmass_ocean_load
-
- integer NSPEC2D_TOP
- integer, dimension(NSPEC2D_TOP) :: ibelm_top
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP) :: jacobian2D_top
-
- ! 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)
-
- double precision RHO_OCEANS
-
- ! local parameters
- double precision weight
- double precision xval,yval,zval,rval,thetaval,phival
- double precision lat,lon,colat
- double precision elevation,height_oceans
- real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
-
- integer :: ispec,i,j,k,iglobnum
- integer :: ix_oceans,iy_oceans,iz_oceans,ispec_oceans,ispec2D_top_crust
-
-
- ! initializes
- rmass(:) = 0._CUSTOM_REAL
-
- do ispec=1,nspec
-
- ! suppress fictitious elements in central cube
- if(idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- weight = wxgll(i)*wygll(j)*wzgll(k)
- iglobnum = ibool(i,j,k,ispec)
-
- ! compute the jacobian
- xixl = xixstore(i,j,k,ispec)
- xiyl = xiystore(i,j,k,ispec)
- xizl = xizstore(i,j,k,ispec)
- etaxl = etaxstore(i,j,k,ispec)
- etayl = etaystore(i,j,k,ispec)
- etazl = etazstore(i,j,k,ispec)
- gammaxl = gammaxstore(i,j,k,ispec)
- gammayl = gammaystore(i,j,k,ispec)
- gammazl = gammazstore(i,j,k,ispec)
-
- 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(i,j,k,ispec)) * dble(jacobianl) * weight)
- else
- rmass(iglobnum) = rmass(iglobnum) + rhostore(i,j,k,ispec) * 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(i,j,k,ispec)) / dble(kappavstore(i,j,k,ispec)))
- else
- rmass(iglobnum) = rmass(iglobnum) + &
- jacobianl * weight * rhostore(i,j,k,ispec) / kappavstore(i,j,k,ispec)
- endif
-
- else
- call exit_MPI(myrank,'wrong region code')
- endif
-
- enddo
- enddo
- enddo
- enddo
-
- ! save ocean load mass matrix as well if oceans
- if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
-
- ! create ocean load mass matrix for degrees of freedom at ocean bottom
- rmass_ocean_load(:) = 0._CUSTOM_REAL
-
- ! add contribution of the oceans
- ! for surface elements exactly at the top of the crust (ocean bottom)
- do ispec2D_top_crust = 1,NSPEC2D_TOP
-
- ispec_oceans = ibelm_top(ispec2D_top_crust)
-
- iz_oceans = NGLLZ
-
- do ix_oceans = 1,NGLLX
- do iy_oceans = 1,NGLLY
-
- iglobnum=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
-
- ! if 3D Earth, compute local height of oceans
- if(CASE_3D) then
-
- ! get coordinates of current point
- xval = xstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
- yval = ystore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
- zval = zstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
-
- ! map to latitude and longitude for bathymetry routine
- call xyz_2_rthetaphi_dble(xval,yval,zval,rval,thetaval,phival)
- call reduce(thetaval,phival)
-
- ! convert the geocentric colatitude to a geographic colatitude
- colat = PI/2.0d0 - datan(1.006760466d0*dcos(thetaval)/dmax1(TINYVAL,dsin(thetaval)))
-
- ! get geographic latitude and longitude in degrees
- lat = 90.0d0 - colat*180.0d0/PI
- lon = phival*180.0d0/PI
- elevation = 0.d0
-
- ! compute elevation at current point
- call get_topo_bathy(lat,lon,elevation,ibathy_topo)
-
- ! non-dimensionalize the elevation, which is in meters
- ! and suppress positive elevation, which means no oceans
- if(elevation >= - MINIMUM_THICKNESS_3D_OCEANS) then
- height_oceans = 0.d0
- else
- height_oceans = dabs(elevation) / R_EARTH
- endif
-
- else
- ! if 1D Earth, use oceans of constant thickness everywhere
- height_oceans = THICKNESS_OCEANS_PREM
- endif
-
- ! take into account inertia of water column
- weight = wxgll(ix_oceans)*wygll(iy_oceans)*dble(jacobian2D_top(ix_oceans,iy_oceans,ispec2D_top_crust)) &
- * dble(RHO_OCEANS) * height_oceans
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + sngl(weight)
- else
- rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + weight
- endif
-
- enddo
- enddo
-
- enddo
-
- ! add regular mass matrix to ocean load contribution
- rmass_ocean_load(:) = rmass_ocean_load(:) + rmass(:)
-
- endif
-
- end subroutine create_mass_matrices
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_AVS_DX.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_AVS_DX.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1024 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!
-!--- create a movie of radial component of surface displacement
-!--- in AVS or OpenDX format
-!
-
- program xcreate_movie_AVS_DX
-
- implicit none
-
- integer it1,it2
- integer iformat
-
-! parameters read from parameter file
- integer NEX_XI,NEX_ETA
- integer NSTEP,NTSTEP_BETWEEN_FRAMES,NCHUNKS
- integer NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
- logical MOVIE_SURFACE
-
-! ************** PROGRAM STARTS HERE **************
-
- call read_AVS_DX_parameters(NEX_XI,NEX_ETA, &
- NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NCHUNKS,MOVIE_SURFACE, &
- NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
-
- if(.not. MOVIE_SURFACE) stop 'movie frames were not saved by the solver'
-
- print *,'1 = create files in OpenDX format'
- print *,'2 = create files in AVS UCD format with individual files'
- print *,'3 = create files in AVS UCD format with one time-dependent file'
- print *,'4 = create files in GMT xyz Ascii long/lat/Uz format'
- print *,'any other value = exit'
- print *
- print *,'enter value:'
- read(5,*) iformat
- if(iformat<1 .or. iformat>4) stop 'exiting...'
-
- print *,'movie frames have been saved every ',NTSTEP_BETWEEN_FRAMES,' time steps'
- print *
-
- print *,'enter first time step of movie (e.g. 1)'
- read(5,*) it1
-
- print *,'enter last time step of movie (e.g. ',NSTEP,')'
- read(5,*) it2
-
-! run the main program
- call create_movie_AVS_DX(iformat,it1,it2, &
- NEX_XI,NEX_ETA, &
- NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NCHUNKS, &
- NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
-
- end program xcreate_movie_AVS_DX
-
-!
-!=====================================================================
-!
-
- subroutine create_movie_AVS_DX(iformat,it1,it2,NEX_XI,NEX_ETA,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NCHUNKS,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
-
- implicit none
-
- include "constants.h"
-
-! threshold in percent of the maximum below which we cut the amplitude
- real(kind=CUSTOM_REAL), parameter :: THRESHOLD = 1._CUSTOM_REAL / 100._CUSTOM_REAL
-
-! flag to apply non linear scaling to normalized norm of displacement
- logical, parameter :: NONLINEAR_SCALING = .false.
- logical, parameter :: FIX_SCALING = .false. ! uses fixed max_value to normalize instead of max of current wavefield
- real,parameter:: MAX_VALUE = 6.77e-4
-
-! coefficient of power law used for non linear scaling
- real(kind=CUSTOM_REAL), parameter :: POWER_SCALING = 0.30_CUSTOM_REAL
-
-! flag to cut amplitude below a certain threshold
- logical, parameter :: APPLY_THRESHOLD = .true.
-
- integer i,j,it
- integer it1,it2
- integer nspectot_AVS_max
- integer ispec
- integer ibool_number,ibool_number1,ibool_number2,ibool_number3,ibool_number4
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: x,y,z,displn
- real(kind=CUSTOM_REAL) xcoord,ycoord,zcoord,rval,thetaval,phival,lat,long
- real(kind=CUSTOM_REAL) displx,disply,displz
- real(kind=CUSTOM_REAL) normal_x,normal_y,normal_z
- double precision min_field_current,max_field_current,max_absol
- logical USE_OPENDX,UNIQUE_FILE,USE_GMT,USE_AVS
- integer iformat,nframes,iframe
-
- character(len=150) outputname
-
- integer iproc,ipoin
-
-! for sorting routine
- integer npointot,ilocnum,nglob,ielm,ieoff,ispecloc
- integer, dimension(:), allocatable :: iglob,loc,ireorder
- logical, dimension(:), allocatable :: ifseg,mask_point
- double precision, dimension(:), allocatable :: xp,yp,zp,xp_save,yp_save,zp_save,field_display
-
-! for dynamic memory allocation
- integer ierror
-
-! movie files stored by solver
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz
-
-! parameters read from file or deduced from parameters read from file
- integer NEX_XI,NEX_ETA
- integer NSTEP,NTSTEP_BETWEEN_FRAMES,NCHUNKS
- integer NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
-
- character(len=150) OUTPUT_FILES
-
-! --------------------------------------
-
- if(iformat == 1) then
- USE_OPENDX = .true.
- USE_AVS = .false.
- USE_GMT = .false.
- UNIQUE_FILE = .false.
- else if(iformat == 2) then
- USE_OPENDX = .false.
- USE_AVS = .true.
- USE_GMT = .false.
- UNIQUE_FILE = .false.
- else if(iformat == 3) then
- USE_OPENDX = .false.
- USE_AVS = .true.
- USE_GMT = .false.
- UNIQUE_FILE = .true.
- else if(iformat == 4) then
- USE_OPENDX = .false.
- USE_AVS = .false.
- USE_GMT = .true.
- UNIQUE_FILE = .false.
- else
- stop 'error: invalid format'
- endif
-
- print *
- print *,'Recombining all movie frames to create a movie'
- print *
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
- print *
- print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
- print *
-
- ilocnum = NGLLX * NGLLY * NEX_PER_PROC_XI * NEX_PER_PROC_ETA
-
- print *
- print *,'Allocating arrays of size ',ilocnum*NPROCTOT
- print *
-
- allocate(store_val_x(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_x'
-
- allocate(store_val_y(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_y'
-
- allocate(store_val_z(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_z'
-
- allocate(store_val_ux(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_ux'
-
- allocate(store_val_uy(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_uy'
-
- allocate(store_val_uz(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_uz'
-
- allocate(x(NGLLX,NGLLY),stat=ierror)
- if(ierror /= 0) stop 'error while allocating x'
-
- allocate(y(NGLLX,NGLLY),stat=ierror)
- if(ierror /= 0) stop 'error while allocating y'
-
- allocate(z(NGLLX,NGLLY),stat=ierror)
- if(ierror /= 0) stop 'error while allocating z'
-
- allocate(displn(NGLLX,NGLLY),stat=ierror)
- if(ierror /= 0) stop 'error while allocating displn'
-
- print *
- print *,'looping from ',it1,' to ',it2,' every ',NTSTEP_BETWEEN_FRAMES,' time steps'
-
-! count number of movie frames
- nframes = 0
- do it = it1,it2
- if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) nframes = nframes + 1
- enddo
- print *
- print *,'total number of frames will be ',nframes
- if(nframes == 0) stop 'null number of frames'
-
-! Make OpenDX think that each "grid cell" between GLL points is actually
-! a finite element with four corners. This means that inside each real
-! spectral element one should have (NGLL-1)^2 OpenDX "elements"
-
-! define the total number of OpenDX "elements" at the surface
- nspectot_AVS_max = NCHUNKS * NEX_XI * NEX_ETA * (NGLLX-1) * (NGLLY-1)
-
- print *
- print *,'there are a total of ',nspectot_AVS_max,' OpenDX "elements" at the surface'
- print *
-
-! maximum theoretical number of points at the surface
- npointot = NGNOD2D_AVS_DX * nspectot_AVS_max
-
- print *
- print *,'Allocating arrays of size ',npointot
- print *
-
-! allocate arrays for sorting routine
- allocate(iglob(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating iglob'
-
- allocate(loc(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating loc'
-
- allocate(ifseg(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating ifseg'
-
- allocate(xp(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating xp'
-
- allocate(yp(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating yp'
-
- allocate(zp(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating zp'
-
- allocate(xp_save(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating xp_save'
-
- allocate(yp_save(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating yp_save'
-
- allocate(zp_save(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating zp_save'
-
- allocate(field_display(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating field_display'
-
- allocate(mask_point(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating mask_point'
-
- allocate(ireorder(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating ireorder'
-
-!--- ****** read data saved by solver ******
-
- print *
-
- if(APPLY_THRESHOLD) print *,'Will apply a threshold to amplitude below ',100.*THRESHOLD,' %'
-
- if(NONLINEAR_SCALING) print *,'Will apply a non linear scaling with coef ',POWER_SCALING
-
-! --------------------------------------
-
- iframe = 0
-
-! loop on all the time steps in the range entered
- do it = it1,it2
-
-! check if time step corresponds to a movie frame
- if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
-
- iframe = iframe + 1
-
- print *
- print *,'reading snapshot time step ',it,' out of ',NSTEP
- print *
-
-! read all the elements from the same file
- write(outputname,"('/moviedata',i6.6)") it
- open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='old',action='read',form='unformatted')
- read(IOUT) store_val_x
- read(IOUT) store_val_y
- read(IOUT) store_val_z
- read(IOUT) store_val_ux
- read(IOUT) store_val_uy
- read(IOUT) store_val_uz
- close(IOUT)
-
-! clear number of elements kept
- ispec = 0
-
-! read points for all the slices
- do iproc = 0,NPROCTOT-1
-
-! reset point number
- ipoin = 0
-
- do ispecloc = 1,NEX_PER_PROC_XI*NEX_PER_PROC_ETA
-
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- ipoin = ipoin + 1
-
- xcoord = store_val_x(ipoin,iproc)
- ycoord = store_val_y(ipoin,iproc)
- zcoord = store_val_z(ipoin,iproc)
-
- displx = store_val_ux(ipoin,iproc)
- disply = store_val_uy(ipoin,iproc)
- displz = store_val_uz(ipoin,iproc)
-
-! coordinates actually contain r theta phi, therefore convert back to x y z
- rval = xcoord
- thetaval = ycoord
- phival = zcoord
- call rthetaphi_2_xyz(xcoord,ycoord,zcoord,rval,thetaval,phival)
-
-! compute unit normal vector to the surface
- normal_x = xcoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
- normal_y = ycoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
- normal_z = zcoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
-
-! save the results for this element
- x(i,j) = xcoord
- y(i,j) = ycoord
- z(i,j) = zcoord
- displn(i,j) = displx*normal_x + disply*normal_y + displz*normal_z
-
- enddo
- enddo
-
-! assign the values of the corners of the OpenDX "elements"
- ispec = ispec + 1
- ielm = (NGLLX-1)*(NGLLY-1)*(ispec-1)
- do j = 1,NGLLY-1
- do i = 1,NGLLX-1
- ieoff = NGNOD2D_AVS_DX*(ielm+(i-1)+(j-1)*(NGLLX-1))
- do ilocnum = 1,NGNOD2D_AVS_DX
- if(ilocnum == 1) then
- xp(ieoff+ilocnum) = dble(x(i,j))
- yp(ieoff+ilocnum) = dble(y(i,j))
- zp(ieoff+ilocnum) = dble(z(i,j))
- field_display(ieoff+ilocnum) = dble(displn(i,j))
- elseif(ilocnum == 2) then
- xp(ieoff+ilocnum) = dble(x(i+1,j))
- yp(ieoff+ilocnum) = dble(y(i+1,j))
- zp(ieoff+ilocnum) = dble(z(i+1,j))
- field_display(ieoff+ilocnum) = dble(displn(i+1,j))
- elseif(ilocnum == 3) then
- xp(ieoff+ilocnum) = dble(x(i+1,j+1))
- yp(ieoff+ilocnum) = dble(y(i+1,j+1))
- zp(ieoff+ilocnum) = dble(z(i+1,j+1))
- field_display(ieoff+ilocnum) = dble(displn(i+1,j+1))
- else
- xp(ieoff+ilocnum) = dble(x(i,j+1))
- yp(ieoff+ilocnum) = dble(y(i,j+1))
- zp(ieoff+ilocnum) = dble(z(i,j+1))
- field_display(ieoff+ilocnum) = dble(displn(i,j+1))
- endif
- enddo
- enddo
- enddo
-
- enddo
-
- enddo
-
-! compute min and max of data value to normalize
- min_field_current = minval(field_display(:))
- max_field_current = maxval(field_display(:))
-
-! make sure range is always symmetric and center is in zero
-! this assumption works only for fields that can be negative
-! would not work for norm of vector for instance
-! (we would lose half of the color palette if no negative values)
- max_absol = max(abs(min_field_current),abs(max_field_current))
- min_field_current = - max_absol
- max_field_current = + max_absol
-
-! print minimum and maximum amplitude in current snapshot
- print *
- print *,'minimum amplitude in current snapshot = ',min_field_current
- print *,'maximum amplitude in current snapshot = ',max_field_current
- if( FIX_SCALING ) then
- print *,' to be normalized by : ',MAX_VALUE
- if( max_field_current > MAX_VALUE ) stop 'increase MAX_VALUE'
- endif
- print *
-
-
-
-! normalize field to [0:1]
- print *,'normalizing... '
- if( FIX_SCALING ) then
- field_display(:) = (field_display(:) + MAX_VALUE) / (2.0*MAX_VALUE)
- else
- field_display(:) = (field_display(:) - min_field_current) / (max_field_current - min_field_current)
- endif
-! rescale to [-1,1]
- field_display(:) = 2.*field_display(:) - 1.
-
-! apply threshold to normalized field
- if(APPLY_THRESHOLD) then
- print *,'thresholding... '
- where(abs(field_display(:)) <= THRESHOLD) field_display = 0.
- endif
-
-! apply non linear scaling to normalized field if needed
- if(NONLINEAR_SCALING) then
- print *,'nonlinear scaling... '
- where(field_display(:) >= 0.)
- field_display = field_display ** POWER_SCALING
- elsewhere
- field_display = - abs(field_display) ** POWER_SCALING
- endwhere
- endif
-
- print *,'color scaling... '
-! map back to [0,1]
- field_display(:) = (field_display(:) + 1.) / 2.
-
-! map field to [0:255] for AVS color scale
- field_display(:) = 255. * field_display(:)
-
-
-! copy coordinate arrays since the sorting routine does not preserve them
- print *,'sorting... '
- xp_save(:) = xp(:)
- yp_save(:) = yp(:)
- zp_save(:) = zp(:)
-
-!--- sort the list based upon coordinates to get rid of multiples
- print *,'sorting list of points'
- call get_global_AVS(nspectot_AVS_max,xp,yp,zp,iglob,loc,ifseg,nglob,npointot)
-
-!--- print total number of points found
- print *
- print *,'found a total of ',nglob,' points'
- print *,'initial number of points (with multiples) was ',npointot
-
-!--- ****** create AVS file using sorted list ******
-
-! create file name and open file
- if(USE_OPENDX) then
- write(outputname,"('/DX_movie_',i6.6,'.dx')") it
- open(unit=11,file=trim(OUTPUT_FILES)//outputname,status='unknown')
- write(11,*) 'object 1 class array type float rank 1 shape 3 items ',nglob,' data follows'
- else if(USE_AVS) then
- if(UNIQUE_FILE .and. iframe == 1) then
- open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_movie_all.inp',status='unknown')
- write(11,*) nframes
- write(11,*) 'data'
- write(11,"('step',i1,' image',i1)") 1,1
- write(11,*) nglob,' ',nspectot_AVS_max
- else if(.not. UNIQUE_FILE) then
- write(outputname,"('/AVS_movie_',i6.6,'.inp')") it
- open(unit=11,file=trim(OUTPUT_FILES)//outputname,status='unknown')
- write(11,*) nglob,' ',nspectot_AVS_max,' 1 0 0'
- endif
- else if(USE_GMT) then
- write(outputname,"('/gmt_movie_',i6.6,'.xyz')") it
- open(unit=11,file=trim(OUTPUT_FILES)//outputname,status='unknown')
- else
- stop 'wrong output format selected'
- endif
-
- if(USE_GMT) then
-
- ! output list of points
- mask_point = .false.
- do ispec=1,nspectot_AVS_max
- ieoff = NGNOD2D_AVS_DX*(ispec-1)
- ! four points for each element
- do ilocnum = 1,NGNOD2D_AVS_DX
- ibool_number = iglob(ilocnum+ieoff)
- if(.not. mask_point(ibool_number)) then
- xcoord = sngl(xp_save(ilocnum+ieoff))
- ycoord = sngl(yp_save(ilocnum+ieoff))
- zcoord = sngl(zp_save(ilocnum+ieoff))
- call xyz_2_rthetaphi(xcoord,ycoord,zcoord,rval,thetaval,phival)
-
- ! note: converts the geocentric colatitude to a geographic colatitude
- if(.not. ASSUME_PERFECT_SPHERE) then
- thetaval = PI/2.0d0 - &
- datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dble(sin(thetaval))))
- endif
-
- lat = (PI/2.0-thetaval)*180.0/PI
- long = phival*180.0/PI
- if(long > 180.0) long = long-360.0
- write(11,*) long,lat,sngl(field_display(ilocnum+ieoff))
- endif
- mask_point(ibool_number) = .true.
- enddo
- enddo
-
- else
-! if unique file, output geometry only once
- if(.not. UNIQUE_FILE .or. iframe == 1) then
-
-! output list of points
- mask_point = .false.
- ipoin = 0
- do ispec=1,nspectot_AVS_max
- ieoff = NGNOD2D_AVS_DX*(ispec-1)
-! four points for each element
- do ilocnum = 1,NGNOD2D_AVS_DX
- ibool_number = iglob(ilocnum+ieoff)
- if(.not. mask_point(ibool_number)) then
- ipoin = ipoin + 1
- ireorder(ibool_number) = ipoin
- if(USE_OPENDX) then
- write(11,"(f10.7,1x,f10.7,1x,f10.7)") &
- xp_save(ilocnum+ieoff),yp_save(ilocnum+ieoff),zp_save(ilocnum+ieoff)
- else if(USE_AVS) then
- write(11,"(i10,1x,f10.7,1x,f10.7,1x,f10.7)") ireorder(ibool_number), &
- xp_save(ilocnum+ieoff),yp_save(ilocnum+ieoff),zp_save(ilocnum+ieoff)
- endif
- endif
- mask_point(ibool_number) = .true.
- enddo
- enddo
-
- if(USE_OPENDX) &
- write(11,*) 'object 2 class array type int rank 1 shape 4 items ',nspectot_AVS_max,' data follows'
-
-! output list of elements
- do ispec=1,nspectot_AVS_max
- ieoff = NGNOD2D_AVS_DX*(ispec-1)
-! four points for each element
- ibool_number1 = iglob(ieoff + 1)
- ibool_number2 = iglob(ieoff + 2)
- ibool_number3 = iglob(ieoff + 3)
- ibool_number4 = iglob(ieoff + 4)
- if(USE_OPENDX) then
-! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
- write(11,"(i10,1x,i10,1x,i10,1x,i10)") ireorder(ibool_number1)-1, &
- ireorder(ibool_number4)-1,ireorder(ibool_number2)-1,ireorder(ibool_number3)-1
- else
- write(11,"(i10,' 1 quad ',i10,1x,i10,1x,i10,1x,i10)") ispec,ireorder(ibool_number1), &
- ireorder(ibool_number2),ireorder(ibool_number3),ireorder(ibool_number4)
- endif
- enddo
-
- endif
-
- if(USE_OPENDX) then
- write(11,*) 'attribute "element type" string "quads"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items ',nglob,' data follows'
- else
- if(UNIQUE_FILE) then
-! step number for AVS multistep file
- if(iframe > 1) then
- if(iframe < 10) then
- write(11,"('step',i1,' image',i1)") iframe,iframe
- else if(iframe < 100) then
- write(11,"('step',i2,' image',i2)") iframe,iframe
- else if(iframe < 1000) then
- write(11,"('step',i3,' image',i3)") iframe,iframe
- else
- write(11,"('step',i4,' image',i4)") iframe,iframe
- endif
- endif
- write(11,*) '1 0'
- endif
-! dummy text for labels
- write(11,*) '1 1'
- write(11,*) 'a, b'
- endif
-
-! output data values
- mask_point = .false.
-
-! output point data
- do ispec=1,nspectot_AVS_max
- ieoff = NGNOD2D_AVS_DX*(ispec-1)
-! four points for each element
- do ilocnum = 1,NGNOD2D_AVS_DX
- ibool_number = iglob(ilocnum+ieoff)
- if(.not. mask_point(ibool_number)) then
- if(USE_OPENDX) then
- write(11,"(f7.2)") field_display(ilocnum+ieoff)
- else
- write(11,"(i10,1x,f7.2)") ireorder(ibool_number),field_display(ilocnum+ieoff)
- endif
- endif
- mask_point(ibool_number) = .true.
- enddo
- enddo
-
-! define OpenDX field
- if(USE_OPENDX) then
- write(11,*) 'attribute "dep" string "positions"'
- write(11,*) 'object "irregular positions irregular connections" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
- endif
-
-! end of test for GMT format
- endif
-
- if(.not. UNIQUE_FILE) close(11)
-
-! end of loop and test on all the time steps for all the movie images
- endif
- enddo
-
- if(UNIQUE_FILE) close(11)
-
- print *
- print *,'done creating movie'
- print *
- if(USE_OPENDX) print *,'DX files are stored in ', trim(OUTPUT_FILES), '/DX_*.dx'
- if(USE_AVS) print *,'AVS files are stored in ', trim(OUTPUT_FILES), '/AVS_*.inp'
- if(USE_GMT) print *,'GMT files are stored in ', trim(OUTPUT_FILES), '/gmt_*.xyz'
- print *
-
- end subroutine create_movie_AVS_DX
-
-!
-!=====================================================================
-!
-
- subroutine read_params_and_create_movie
-
-!
-! This routine is called by the Pyrized version.
-!
-
- implicit none
-
- integer it1,it2
- integer iformat
-
-! parameters read from parameter file
- integer NEX_XI,NEX_ETA
- integer NSTEP,NTSTEP_BETWEEN_FRAMES,NCHUNKS
- integer NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
- logical MOVIE_SURFACE
-
- integer, external :: err_occurred
-
- call read_AVS_DX_parameters(NEX_XI,NEX_ETA, &
- NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NCHUNKS,MOVIE_SURFACE, &
- NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
-
-! read additional parameters for making movies
- call read_value_integer(iformat, 'format')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(it1, 'beginning')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(it2, 'end')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
-! run the main program
- call create_movie_AVS_DX(iformat,it1,it2, &
- NEX_XI,NEX_ETA, &
- NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NCHUNKS, &
- NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
-
- end subroutine read_params_and_create_movie
-
-! ------------------------------------------------------------------
-
- subroutine read_AVS_DX_parameters(NEX_XI,NEX_ETA, &
- NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NCHUNKS,MOVIE_SURFACE, &
- NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- 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
-
-! 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
- 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
-
-! 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
-
- character(len=150) LOCAL_PATH,MODEL
- 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
-
- print *
- print *,'reading parameter file'
- print *
-
-! read the parameter file and compute additional parameters
-
- call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
-
- if(MOVIE_COARSE) stop 'create_movie_AVS_DX does not work with MOVIE_COARSE'
-
- end subroutine read_AVS_DX_parameters
-
-! ------------------------------------------------------------------
-
- subroutine get_global_AVS(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
-
-! leave sorting subroutines in same source file to allow for inlining
-
- implicit none
-
- include "constants.h"
-
- integer npointot
- integer iglob(npointot),loc(npointot)
- logical ifseg(npointot)
- double precision xp(npointot),yp(npointot),zp(npointot)
- integer nspec,nglob
-
- integer ispec,i,j
- integer ieoff,ilocnum,nseg,ioff,iseg,ig
-
-! for dynamic memory allocation
- integer ierror
-
- integer, dimension(:), allocatable :: ind,ninseg,iwork
- double precision, dimension(:), allocatable :: work
-
- print *
- print *,'Allocating arrays of size ',npointot
- print *
-
-! dynamically allocate arrays
- allocate(ind(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating ind'
-
- allocate(ninseg(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating ninseg'
-
- allocate(iwork(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating iwork'
-
- allocate(work(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating work'
-
-! establish initial pointers
- do ispec=1,nspec
- ieoff=NGNOD2D_AVS_DX*(ispec-1)
- do ilocnum=1,NGNOD2D_AVS_DX
- loc(ieoff+ilocnum)=ieoff+ilocnum
- 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)
-
-! -----------------------------------
-
-! get_global_AVS internal procedures follow
-
-! sorting routines put in same file to allow for inlining
-
- contains
-
-! -----------------------------------
-
- 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
-
-! ------------------------------------------------------------------
-
- end subroutine get_global_AVS
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_GMT_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_GMT_global.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_GMT_global.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,790 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!
-!--- create a movie of radial component of surface displacement in GMT format
-!
-
- program create_movie_GMT_global
-
-! reads in files: OUTPUT_FILES/moviedata******
-!
-! and creates new files: ascii_movie_*** (ascii option) /or/ bin_movie_*** (binary option)
-!
-! these files can then be visualized using GMT, the Generic Mapping Tools
-! ( http://www.soest.hawaii.edu/GMT/ )
-!
-! example scripts can be found in: UTILS/Visualization/GMT/
-
- implicit none
-
- include "constants.h"
-
-!---------------------
-! USER PARAMETER
-
- ! to avoid flickering in movies, the displacement field will get normalized with an
- ! averaged maximum value over the past few, available snapshots
- logical,parameter :: USE_AVERAGED_MAXIMUM = .true.
-
- ! minimum number of frames to average maxima
- integer,parameter :: AVERAGE_MINIMUM = 5
-
- ! muting source region
- logical, parameter :: MUTE_SOURCE = .true.
- real(kind=CUSTOM_REAL) :: RADIUS_TO_MUTE = 1.0 ! start radius in degrees
- real(kind=CUSTOM_REAL) :: STARTTIME_TO_MUTE = 2.0 ! factor times hdur_movie
-
- ! normalizes output values
- logical, parameter :: NORMALIZE_VALUES = .true.
-
-!---------------------
-
- integer i,j,it
- integer it1,it2
- integer ispec
-
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: x,y,z,displn
- real(kind=CUSTOM_REAL) xcoord,ycoord,zcoord,rval,thetaval,phival
- real(kind=CUSTOM_REAL) RRval,rhoval
- real(kind=CUSTOM_REAL) displx,disply,displz
- real(kind=CUSTOM_REAL) normal_x,normal_y,normal_z
- real(kind=CUSTOM_REAL) thetahat_x,thetahat_y,thetahat_z
- real(kind=CUSTOM_REAL) phihat_x,phihat_y
-
- ! to average maxima over past few steps
- double precision min_field_current,max_field_current,max_absol,max_average
- double precision,dimension(:),allocatable :: max_history
- integer :: nmax_history,imax
-
- real disp,lat,long
- integer nframes,iframe,USE_COMPONENT
-
- character(len=150) outputname
-
- integer iproc,ipoin
-
-! for sorting routine
- integer npointot,ilocnum,ielm,ieoff,ispecloc,NIT
- double precision, dimension(:), allocatable :: xp,yp,zp,field_display
-
-! for dynamic memory allocation
- integer ierror
-
-! movie files stored by solver
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- 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
-
-! 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
-
-
- 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,OUTPUT_BINARY
-
- 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
-
- real(kind=CUSTOM_REAL) :: LAT_SOURCE,LON_SOURCE,DEP_SOURCE
- real(kind=CUSTOM_REAL) :: dist_lon,dist_lat,mute_factor
- character(len=256) line
-
-! ************** PROGRAM STARTS HERE **************
-
- print *
- print *,'Recombining all movie frames to create a movie'
- print *,'Run this program from the directory containing directories DATA and OUTPUT_FILES'
-
- print *
- print *,'reading parameter file'
- print *
-
-! read the parameter file and compute additional parameters
- call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
-
- if(.not. MOVIE_SURFACE) stop 'movie frames were not saved by the solver'
-
- print *
- print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
- print *
- if(MOVIE_COARSE) then
- ! note:
- ! nex_per_proc_xi*nex_per_proc_eta = nex_xi*nex_eta/nproc = nspec2d_top(iregion_crust_mantle) used in specfem3D.f90
- ! and ilocnum = nmovie_points = 2 * 2 * NEX_XI * NEX_ETA / NPROC
- ilocnum = 2 * 2 * NEX_PER_PROC_XI*NEX_PER_PROC_ETA
- NIT =NGLLX-1
- else
- ilocnum = NGLLX*NGLLY*NEX_PER_PROC_XI*NEX_PER_PROC_ETA
- NIT = 1
- endif
- print *
- print *,'Allocating arrays for reading data of size ',ilocnum*NPROCTOT,'=',6*ilocnum*NPROCTOT*CUSTOM_REAL/1000000,'MB'
- print *
-
- ! allocates movie arrays
- allocate(store_val_x(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_x'
-
- allocate(store_val_y(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_y'
-
- allocate(store_val_z(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_z'
-
- allocate(store_val_ux(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_ux'
-
- allocate(store_val_uy(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_uy'
-
- allocate(store_val_uz(ilocnum,0:NPROCTOT-1),stat=ierror)
- if(ierror /= 0) stop 'error while allocating store_val_uz'
-
- allocate(x(NGLLX,NGLLY),stat=ierror)
- if(ierror /= 0) stop 'error while allocating x'
-
- allocate(y(NGLLX,NGLLY),stat=ierror)
- if(ierror /= 0) stop 'error while allocating y'
-
- allocate(z(NGLLX,NGLLY),stat=ierror)
- if(ierror /= 0) stop 'error while allocating z'
-
- allocate(displn(NGLLX,NGLLY),stat=ierror)
- if(ierror /= 0) stop 'error while allocating displn'
-
- print *,'movie frames have been saved every ',NTSTEP_BETWEEN_FRAMES,' time steps'
- print *
-
- ! user input
- print *,'--------'
- print *,'enter first time step of movie (e.g. 1)'
- read(5,*) it1
-
- print *,'enter last time step of movie (e.g. ',NSTEP,'or -1 for all)'
- read(5,*) it2
-
- print *,'enter component (e.g. 1=Z, 2=N, 3=E)'
- read(5,*) USE_COMPONENT
-
- print *,'enter output ascii (F) or binary (T)'
- read(5,*) OUTPUT_BINARY
- print *,'--------'
-
- ! checks options
- if( it2 == -1 ) it2 = NSTEP
-
- print *
- print *,'looping from ',it1,' to ',it2,' every ',NTSTEP_BETWEEN_FRAMES,' time steps'
-
- ! counts number of movie frames
- nframes = 0
- do it = it1,it2
- if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) nframes = nframes + 1
- enddo
- print *
- print *,'total number of frames will be ',nframes
- if(nframes == 0) stop 'null number of frames'
-
- ! maximum theoretical number of points at the surface
- if(MOVIE_COARSE) then
- npointot = NCHUNKS * NEX_XI * NEX_ETA
- else
- npointot = NCHUNKS * NEX_XI * NEX_ETA * (NGLLX-1) * (NGLLY-1)
- endif
-
- print *
- print *,'there are a total of ',npointot,' points on the surface.'
- print *
-
-
- print *
- print *,'Allocating 4 outputdata arrays of size 4*CUSTOM_REAL',npointot,'=',4*npointot*CUSTOM_REAL/1000000,' MB'
- print *
-
- allocate(xp(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating xp'
-
- allocate(yp(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating yp'
-
- allocate(zp(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating zp'
-
- allocate(field_display(npointot),stat=ierror)
- if(ierror /= 0) stop 'error while allocating field_display'
-
-
- ! initializes maxima history
- if( USE_AVERAGED_MAXIMUM ) then
- ! determines length of history
- nmax_history = AVERAGE_MINIMUM + int( HDUR_MOVIE / (DT*NTSTEP_BETWEEN_FRAMES) * 1.5 )
-
- ! allocates history array
- allocate(max_history(nmax_history))
- max_history(:) = 0.0d0
-
- print *
- print *,'Movie half-duration: ',HDUR_MOVIE,'(s)'
- print *,'Frame step size : ',DT*NTSTEP_BETWEEN_FRAMES,'(s)'
- print *,'Normalization by averaged maxima over ',nmax_history,'snapshots'
- print *
-
- if( MUTE_SOURCE ) then
- ! initializes
- LAT_SOURCE = -1000.0
- LON_SOURCE = -1000.0
-
- ! reads in source lat/lon
- open(22,file="DATA/CMTSOLUTION",status='old',action='read',iostat=ierror )
- if( ierror == 0 ) then
- ! skip first line, event name,timeshift,half duration
- read(22,*,iostat=ierror ) line ! PDE line
- read(22,*,iostat=ierror ) line ! event name
- read(22,*,iostat=ierror ) line ! timeshift
- read(22,*,iostat=ierror ) line ! halfduration
- ! latitude
- read(22,'(a256)',iostat=ierror ) line
- if( ierror == 0 ) read(line(10:len_trim(line)),*) LAT_SOURCE
- ! longitude
- read(22,'(a256)',iostat=ierror ) line
- if( ierror == 0 ) read(line(11:len_trim(line)),*) LON_SOURCE
- ! depth
- read(22,'(a256)',iostat=ierror ) line
- if( ierror == 0 ) read(line(11:len_trim(line)),*) DEP_SOURCE
- close(22)
- endif
-
- print *,'muting source lat/lon/dep: ',LAT_SOURCE,LON_SOURCE,DEP_SOURCE
-
- ! becomes time (s) from hypocenter to reach surface (using average 8 km/s p-wave speed)
- DEP_SOURCE = DEP_SOURCE / 8.0
-
- ! time when muting starts
- STARTTIME_TO_MUTE = STARTTIME_TO_MUTE * HDUR_MOVIE + DEP_SOURCE
-
- print *,'muting radius: ',RADIUS_TO_MUTE
- print *,'muting starttime: ',STARTTIME_TO_MUTE,'(s)'
- print *
-
- ! colatitude [0, PI]
- LAT_SOURCE = (90. - LAT_SOURCE)*PI/180.0
-
- ! longitude [-PI, PI]
- if( LON_SOURCE < -180.0 ) LON_SOURCE = LON_SOURCE + 360.0
- if( LON_SOURCE > 180.0 ) LON_SOURCE = LON_SOURCE - 360.0
- LON_SOURCE = LON_SOURCE *PI/180.0
-
- ! mute radius in rad
- RADIUS_TO_MUTE = RADIUS_TO_MUTE*PI/180.0
- endif
-
-
- endif
- print *,'--------'
-
-!--- ****** read data saved by solver ******
-
-! --------------------------------------
-
- iframe = 0
-
-! loop on all the time steps in the range entered
- do it = it1,it2
- ! check if time step corresponds to a movie frame
- if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
-
- iframe = iframe + 1
-
- ! mutes source region
- if( MUTE_SOURCE ) then
-
- ! muting radius grows/shrinks with time
- if( (it-1)*DT > STARTTIME_TO_MUTE ) then
-
- ! approximate wavefront travel distance in degrees (~3.5 km/s wave speed for surface waves)
- mute_factor = 3.5 * (it-1)*DT / 6371. * 180./PI
-
- ! approximate distance to source (in degrees)
- do while ( mute_factor > 360. )
- mute_factor = mute_factor - 360.
- enddo
- if( mute_factor > 180. ) mute_factor = 360. - mute_factor
-
- ! limit size around source (in degrees)
- !if( mute_factor < 10. ) then
- ! mute_factor = 0.0
- !endif
- if( mute_factor > 80. ) then
- mute_factor = 80.0
- endif
-
- print*,'muting radius: ',0.7 * mute_factor
-
- RADIUS_TO_MUTE = 0.7 * mute_factor * PI/180.
-
- else
- ! mute_factor used at the beginning for scaling displacement values
- if( STARTTIME_TO_MUTE > TINYVAL ) then
- ! scales from 1 to 0
- mute_factor = ( STARTTIME_TO_MUTE - (it-1)*DT ) / STARTTIME_TO_MUTE
- if( mute_factor < TINYVAL ) mute_factor = TINYVAL
- else
- mute_factor = 1.0
- endif
- endif
-
- endif
-
- ! read all the elements from the same file
- write(outputname,"('OUTPUT_FILES/moviedata',i6.6)") it
- open(unit=IOUT,file=outputname,status='old',form='unformatted')
-
- print *
- print *,'reading snapshot time step ',it,' out of ',NSTEP,' file ',outputname
- !print *
-
- ! reads in point locations
- ! (given as r theta phi for geocentric coordinate system)
- read(IOUT) store_val_x
- read(IOUT) store_val_y
- read(IOUT) store_val_z
-
- ! reads in associated values (velocity..)
- read(IOUT) store_val_ux
- read(IOUT) store_val_uy
- read(IOUT) store_val_uz
-
- close(IOUT)
- !print *, 'finished reading ',outputname
-
- ! clear number of elements kept
- ispec = 0
-
- ! read points for all the slices
- print *,'Converting to geo-coordinates'
- do iproc = 0,NPROCTOT-1
- ! reset point number
- ipoin = 0
- do ispecloc = 1,NEX_PER_PROC_XI*NEX_PER_PROC_ETA
- do j = 1,NGLLY,NIT
- do i = 1,NGLLX,NIT
- ipoin = ipoin + 1
-
- ! coordinates actually contain r theta phi
- xcoord = store_val_x(ipoin,iproc)
- ycoord = store_val_y(ipoin,iproc)
- zcoord = store_val_z(ipoin,iproc)
-
- displx = store_val_ux(ipoin,iproc)
- disply = store_val_uy(ipoin,iproc)
- displz = store_val_uz(ipoin,iproc)
-
- ! coordinates actually contain r theta phi, therefore convert back to x y z
- rval = xcoord
- thetaval = ycoord
- phival = zcoord
- call rthetaphi_2_xyz(xcoord,ycoord,zcoord,rval,thetaval,phival)
-
- ! save the results for this element
- x(i,j) = xcoord
- y(i,j) = ycoord
- z(i,j) = zcoord
-
-
- if(USE_COMPONENT == 1) then
- ! compute unit normal vector to the surface
- RRval = sqrt(xcoord**2 + ycoord**2 + zcoord**2)
- normal_x = xcoord / RRval
- normal_y = ycoord / RRval
- normal_z = zcoord / RRval
-
- displn(i,j) = displx*normal_x + disply*normal_y + displz*normal_z
-
- elseif(USE_COMPONENT == 2) then
-
- ! compute unit tangent vector to the surface (N-S)
- RRval = sqrt(xcoord**2 + ycoord**2 + zcoord**2)
- rhoval = sqrt(xcoord**2 + ycoord**2)
- thetahat_x = (zcoord*xcoord) / (rhoval*RRval)
- thetahat_y = (zcoord*ycoord) / (rhoval*RRval)
- thetahat_z = - rhoval/RRval
-
- displn(i,j) = - (displx*thetahat_x + disply*thetahat_y + displz*thetahat_z)
- elseif(USE_COMPONENT == 3) then
-
- ! compute unit tangent to the surface (E-W)
- rhoval = sqrt(xcoord**2 + ycoord**2)
- phihat_x = -ycoord / rhoval
- phihat_y = xcoord / rhoval
-
- displn(i,j) = displx*phihat_x + disply*phihat_y
- endif
-
-
- ! mute values
- if( MUTE_SOURCE ) then
-
- ! distance in colatitude
- ! note: this mixes geocentric (point location) and geographic (source location) coordinates;
- ! since we only need approximate distances here, this should be fine for the muting region
- dist_lat = thetaval - LAT_SOURCE
-
- ! distance in longitude
- ! checks source longitude range
- if( LON_SOURCE - RADIUS_TO_MUTE < -PI .or. LON_SOURCE + RADIUS_TO_MUTE > PI ) then
- ! source close to 180. longitudes, shifts range to [0, 2PI]
- if( phival < 0.0 ) phival = phival + 2.0*PI
- if( LON_SOURCE < 0.0 ) then
- dist_lon = phival - (LON_SOURCE + 2.0*PI)
- else
- dist_lon = phival - LON_SOURCE
- endif
- else
- ! source well between range to [-PI, PI]
- ! shifts phival to be like LON_SOURCE between [-PI,PI]
- if( phival > PI ) phival = phival - 2.0*PI
- if( phival < -PI ) phival = phival + 2.0*PI
-
- dist_lon = phival - LON_SOURCE
- endif
-
- ! mutes source region values
- if ( ( dist_lat**2 + dist_lon**2 ) < RADIUS_TO_MUTE**2 ) then
- ! muting takes account of the event time
- if( (it-1)*DT > STARTTIME_TO_MUTE ) then
- displn(i,j) = displn(i,j) * TINYVAL
- else
- displn(i,j) = displn(i,j) * mute_factor
- endif
- endif
-
- endif
-
-
- enddo !i
- enddo !j
-
- ispec = ispec + 1
- if(MOVIE_COARSE) then
- ielm = ispec-1
- else
- ielm = (NGLLX-1)*(NGLLY-1)*(ispec-1)
- endif
- do j = 1,NGLLY-NIT
- do i = 1,NGLLX-NIT
- if(MOVIE_COARSE) then
- ieoff = ielm+1
- else
- ieoff = (ielm+(i-1)+(j-1)*(NGLLX-1))+1
- endif
-
-! for movie_coarse e.g. x(i,j) is defined at x(1,1), x(1,NGLLY), x(NGLLX,1) and x(NGLLX,NGLLY)
-! be aware that for the cubed sphere, the mapping changes for different chunks,
-! i.e. e.g. x(1,1) and x(5,5) flip left and right sides of the elements in geographical coordinates
- if(MOVIE_COARSE) then
- if(NCHUNKS == 6) then
- ! chunks mapped such that element corners increase in long/lat
- select case (iproc/NPROC+1)
- case(CHUNK_AB)
- xp(ieoff) = dble(x(1,NGLLY))
- yp(ieoff) = dble(y(1,NGLLY))
- zp(ieoff) = dble(z(1,NGLLY))
- field_display(ieoff) = dble(displn(1,NGLLY))
- case(CHUNK_AB_ANTIPODE)
- xp(ieoff) = dble(x(1,1))
- yp(ieoff) = dble(y(1,1))
- zp(ieoff) = dble(z(1,1))
- field_display(ieoff) = dble(displn(1,1))
- case(CHUNK_AC)
- xp(ieoff) = dble(x(1,NGLLY))
- yp(ieoff) = dble(y(1,NGLLY))
- zp(ieoff) = dble(z(1,NGLLY))
- field_display(ieoff) = dble(displn(1,NGLLY))
- case(CHUNK_AC_ANTIPODE)
- xp(ieoff) = dble(x(1,1))
- yp(ieoff) = dble(y(1,1))
- zp(ieoff) = dble(z(1,1))
- field_display(ieoff) = dble(displn(1,1))
- case(CHUNK_BC)
- xp(ieoff) = dble(x(1,NGLLY))
- yp(ieoff) = dble(y(1,NGLLY))
- zp(ieoff) = dble(z(1,NGLLY))
- field_display(ieoff) = dble(displn(1,NGLLY))
- case(CHUNK_BC_ANTIPODE)
- xp(ieoff) = dble(x(NGLLX,NGLLY))
- yp(ieoff) = dble(y(NGLLX,NGLLY))
- zp(ieoff) = dble(z(NGLLX,NGLLY))
- field_display(ieoff) = dble(displn(NGLLX,NGLLY))
- case default
- stop 'incorrect chunk number'
- end select
- else
- xp(ieoff) = dble(x(1,1))
- yp(ieoff) = dble(y(1,1))
- zp(ieoff) = dble(z(1,1))
- field_display(ieoff) = dble(displn(1,1))
- endif ! NCHUNKS
- else
- xp(ieoff) = dble(x(i,j))
- yp(ieoff) = dble(y(i,j))
- zp(ieoff) = dble(z(i,j))
- field_display(ieoff) = dble(displn(i,j))
- endif ! MOVIE_COARSE
-
- enddo !i
- enddo !j
-
- enddo !ispec
-
- enddo !nproc
-
- ! compute min and max of data value to normalize
- min_field_current = minval(field_display(:))
- max_field_current = maxval(field_display(:))
-
- ! print minimum and maximum amplitude in current snapshot
- print *
- print *,'minimum amplitude in current snapshot = ',min_field_current
- print *,'maximum amplitude in current snapshot = ',max_field_current
-
- ! takes average over last few snapshots available and uses it
- ! to normalize field values
- if( USE_AVERAGED_MAXIMUM ) then
-
- ! (average) maximum between positive and negative values
- max_absol = (abs(min_field_current)+abs(max_field_current))/2.0
-
- ! stores last few maxima
- ! index between 1 and nmax_history
- imax = mod(iframe-1,nmax_history) + 1
- max_history( imax ) = max_absol
-
- ! average over history
- max_average = sum( max_history )
- if( iframe < nmax_history ) then
- ! history not filled yet, only average over available entries
- max_average = max_average / iframe
- else
- ! average over all history entries
- max_average = max_average / nmax_history
- endif
-
- print *,'maximum amplitude over averaged last snapshots = ',max_average
-
- ! scales field values up to match average
- if( abs(max_absol) > TINYVAL) &
- field_display = field_display * max_average / max_absol
-
- ! thresholds positive & negative maximum values
- where( field_display(:) > max_average ) field_display = max_average
- where( field_display(:) < - max_average ) field_display = -max_average
-
- ! normalizes field values
- if( NORMALIZE_VALUES ) then
- if( abs(max_average) > TINYVAL ) field_display = field_display / max_average
- endif
-
- endif
-
- print *
- print *,'initial number of points (with multiples) was ',npointot
- print *,'final number of points is ',ieoff
-
- !--- ****** create GMT file ******
-
- ! create file name and open file
- if(OUTPUT_BINARY) then
- if(USE_COMPONENT == 1) then
- write(outputname,"('bin_movie_',i6.6,'.d')") it
- elseif(USE_COMPONENT == 2) then
- write(outputname,"('bin_movie_',i6.6,'.N')") it
- elseif(USE_COMPONENT == 3) then
- write(outputname,"('bin_movie_',i6.6,'.E')") it
- endif
- open(unit=11,file='OUTPUT_FILES/'//trim(outputname),status='unknown',form='unformatted')
- if(iframe == 1) open(unit=12,file='OUTPUT_FILES/bin_movie.xy',status='unknown',form='unformatted')
- else
- if(USE_COMPONENT == 1) then
- write(outputname,"('ascii_movie_',i6.6,'.d')") it
- elseif(USE_COMPONENT == 2) then
- write(outputname,"('ascii_movie_',i6.6,'.N')") it
- elseif(USE_COMPONENT == 3) then
- write(outputname,"('ascii_movie_',i6.6,'.E')") it
- endif
- open(unit=11,file='OUTPUT_FILES/'//trim(outputname),status='unknown')
- if(iframe == 1) open(unit=12,file='OUTPUT_FILES/ascii_movie.xy',status='unknown')
- endif
- ! clear number of elements kept
- ispec = 0
-
- ! read points for all the slices
- print *,'Writing output',outputname
- do iproc = 0,NPROCTOT-1
-
- ! reset point number
- ipoin = 0
-
- do ispecloc = 1,NEX_PER_PROC_XI*NEX_PER_PROC_ETA
- ispec = ispec + 1
- if(MOVIE_COARSE) then
- ielm = ispec - 1
- else
- ielm = (NGLLX-1)*(NGLLY-1)*(ispec-1)
- endif
-
- do j = 1,NGLLY-NIT
- do i = 1,NGLLX-NIT
- if(MOVIE_COARSE) then
- ieoff = ielm + 1
- else
- ieoff = (ielm+(i-1)+(j-1)*(NGLLX-1))+1
- endif
-
- ! point position
- if(iframe == 1) then
- ! gets cartesian coordinates
- xcoord = sngl(xp(ieoff))
- ycoord = sngl(yp(ieoff))
- zcoord = sngl(zp(ieoff))
-
- ! location latitude/longitude (with geocentric colatitude theta )
- call xyz_2_rthetaphi(xcoord,ycoord,zcoord,rval,thetaval,phival)
-
- ! converts the geocentric colatitude to a geographic colatitude
- if(.not. ASSUME_PERFECT_SPHERE) then
- thetaval = PI/2.0d0 - &
- datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dble(sin(thetaval))))
- endif
-
- ! gets geographic latitude and longitude in degrees
- lat = sngl(90.d0 - thetaval*180.0/PI)
- long = sngl(phival*180.0/PI)
- if(long > 180.0) long = long-360.0
- endif
-
- ! displacement
- disp = sngl(field_display(ieoff))
-
- ! writes displacement and latitude/longitude to corresponding files
- if(OUTPUT_BINARY) then
- write(11) disp
- if(iframe == 1) write(12) long,lat
- else
- write(11,*) disp
- if(iframe == 1) write(12,*) long,lat
- endif
-
- enddo !i
- enddo !j
- enddo !ispecloc
- enddo !iproc
- close(11)
- if(iframe == 1) close(12)
-
-
-! end of loop and test on all the time steps for all the movie images
- endif
- enddo
-
- print *,'done creating movie'
- print *,'GMT ascii files are stored in ascii_movie_*.{xy,d,E,N}'
- print *,'binary files are stored in bin_movie_*.{xy,d,E,N}'
-
- end program create_movie_GMT_global
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/create_name_database.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_name_database.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_name_database.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_regions_mesh.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_regions_mesh.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1114 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine create_regions_mesh(iregion_code,ibool,idoubling,is_on_a_slice_edge, &
- xstore,ystore,zstore,rmins,rmaxs, &
- iproc_xi,iproc_eta,ichunk,nspec,nspec_tiso, &
- volume_local,area_local_bottom,area_local_top, &
- nglob_theor,npointot, &
- NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE, &
- NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
- myrank,LOCAL_PATH,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,&
- SAVE_MESH_FILES,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
- 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,ipass,ratio_divide_central_cube,&
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta)
-
-! creates the different regions of the mesh
-
- use meshfem3D_models_par
-
- implicit none
-
- ! 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 :: offset_proc_xi,offset_proc_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 :: ner_without_doubling,ilayer,ilayer_loop, &
- ifirst_region,ilast_region,ratio_divide_central_cube
- integer, dimension(:), allocatable :: perm_layer
-
- ! correct number of spectral elements in each block depending on chunk type
- integer nspec,nspec_tiso,nspec_stacey,nspec_actually,nspec_att
-
- integer NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS
-
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
-
- integer NPROC_XI,NPROC_ETA
-
- integer npointot
-
- logical SAVE_MESH_FILES
-
- logical INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
-
- double precision R_CENTRAL_CUBE,RICB,RCMB,R670,RMOHO, &
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- RMOHO_FICTITIOUS_IN_MESHER
-
- double precision RHO_OCEANS
-
- character(len=150) LOCAL_PATH,errmsg
-
- ! 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
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- ! 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
-
- integer, dimension(nspec) :: idoubling
-
-! this for non blocking MPI
- logical, dimension(nspec) :: is_on_a_slice_edge
-
- ! parameters needed to store the radii of the grid points in the spherically symmetric Earth
- double precision rmin,rmax
-
- ! for model density and anisotropy
- integer nspec_ani
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,dvpstore, &
- 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
-
- ! arrays with mesh parameters
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
- ! proc numbers for MPI
- integer myrank
-
- ! check area and volume of the final mesh
- 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
-
- ! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
-
- ! mass matrix and bathymetry for ocean load
- integer nglob_oceans
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
-
- ! boundary parameters locator
- integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax, &
- ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top
-
- ! 2-D jacobians and normals
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
- jacobian2D_xmin,jacobian2D_xmax, &
- jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom,jacobian2D_top
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_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,ispec
- 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 :: USE_ONE_LAYER_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 :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
-
- ! now perform two passes in this part to be able to save memory
- integer :: ipass
-
- logical :: ACTUALLY_STORE_ARRAYS
-
- ! Boundary Mesh
- integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,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
-
- ! create the name for the database of the current slide and region
- call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
-
- ! New Attenuation definition on all GLL points
- ! Attenuation
- if (ATTENUATION) then
- T_c_source = AM_V%QT_c_source
- tau_s(:) = AM_V%Qtau_s(:)
- nspec_att = nspec
- else
- nspec_att = 1
- end if
- allocate(Qmu_store(NGLLX,NGLLY,NGLLZ,nspec_att))
- allocate(tau_e_store(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att))
-
- ! 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))
-
- ! 2D shape functions and their derivatives
- allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ))
- allocate(shape2D_y(NGNOD2D,NGLLX,NGLLZ))
- allocate(shape2D_bottom(NGNOD2D,NGLLX,NGLLY))
- allocate(shape2D_top(NGNOD2D,NGLLX,NGLLY))
- allocate(dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ))
- allocate(dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ))
- allocate(dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY))
- allocate(dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY))
-
- ! array with model density
- allocate(rhostore(NGLLX,NGLLY,NGLLZ,nspec))
- allocate(dvpstore(NGLLX,NGLLY,NGLLZ,nspec))
-
- ! for anisotropy
- allocate(kappavstore(NGLLX,NGLLY,NGLLZ,nspec))
- allocate(muvstore(NGLLX,NGLLY,NGLLZ,nspec))
-
- allocate(kappahstore(NGLLX,NGLLY,NGLLZ,nspec))
- allocate(muhstore(NGLLX,NGLLY,NGLLZ,nspec))
- allocate(eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec))
-
- ! Stacey absorbing boundaries
- if(NCHUNKS /= 6) then
- nspec_stacey = nspec
- else
- nspec_stacey = 1
- endif
- allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey))
- allocate(rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey))
-
- ! anisotropy
- if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
- (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) then
- nspec_ani = nspec
- else
- nspec_ani = 1
- endif
- allocate(c11store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c12store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c13store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c14store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c15store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c16store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c22store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c23store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c24store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c25store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c26store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c33store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c34store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c35store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c36store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c44store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c45store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c46store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c55store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c56store(NGLLX,NGLLY,NGLLZ,nspec_ani))
- allocate(c66store(NGLLX,NGLLY,NGLLZ,nspec_ani))
-
- ! boundary locator
- allocate(iboun(6,nspec))
-
- ! boundary parameters locator
- allocate(ibelm_xmin(NSPEC2DMAX_XMIN_XMAX))
- allocate(ibelm_xmax(NSPEC2DMAX_XMIN_XMAX))
- allocate(ibelm_ymin(NSPEC2DMAX_YMIN_YMAX))
- allocate(ibelm_ymax(NSPEC2DMAX_YMIN_YMAX))
- allocate(ibelm_bottom(NSPEC2D_BOTTOM))
- allocate(ibelm_top(NSPEC2D_TOP))
-
- ! 2-D jacobians and normals
- allocate(jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX))
- allocate(jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX))
- allocate(jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX))
- allocate(jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX))
- allocate(jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM))
- allocate(jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP))
-
- allocate(normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX))
- allocate(normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX))
- allocate(normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX))
- allocate(normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX))
- allocate(normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM))
- allocate(normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP))
-
- ! Stacey
- allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX))
- allocate(nimax(2,NSPEC2DMAX_YMIN_YMAX))
- allocate(njmin(2,NSPEC2DMAX_XMIN_XMAX))
- allocate(njmax(2,NSPEC2DMAX_XMIN_XMAX))
- allocate(nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX))
- allocate(nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX))
-
- ! MPI cut-planes parameters along xi and along eta
- allocate(iMPIcut_xi(2,nspec))
- allocate(iMPIcut_eta(2,nspec))
-
- ! store and save the final arrays only in the second pass
- ! therefore in the first pass some arrays can be allocated with a dummy size
- if(ipass == 1) then
- ACTUALLY_STORE_ARRAYS = .false.
- nspec_actually = 1
- else
- ACTUALLY_STORE_ARRAYS = .true.
- nspec_actually = nspec
- endif
- allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(xiystore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(xizstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(etaxstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(etaystore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(etazstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(gammaxstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(gammaystore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(gammazstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
-
- ! boundary mesh
- if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
- NSPEC2D_MOHO = NSPEC2D_TOP
- NSPEC2D_400 = NSPEC2D_MOHO / 4
- NSPEC2D_670 = NSPEC2D_400
- else
- NSPEC2D_MOHO = 1
- NSPEC2D_400 = 1
- NSPEC2D_670 = 1
- endif
- allocate(ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO))
- allocate(ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400))
- allocate(ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670))
- allocate(normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO))
- allocate(normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400))
- allocate(normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670))
- allocate(jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO))
- allocate(jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400))
- allocate(jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670))
-
- ! initialize number of layers
- call crm_initialize_layers(myrank,ipass,xigll,yigll,zigll,wxgll,wygll,wzgll, &
- shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- iaddx,iaddy,iaddz,nspec,xstore,ystore,zstore,ibool,idoubling, &
- iboun,iMPIcut_xi,iMPIcut_eta,ispec2D_moho_top,ispec2D_moho_bot, &
- ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
- NEX_PER_PROC_ETA,nex_eta_moho,RMOHO,R400,R670,r_moho,r_400,r_670, &
- ONE_CRUST,NUMBER_OF_MESH_LAYERS,layer_shift, &
- iregion_code,ifirst_region,ilast_region, &
- first_layer_aniso,last_layer_aniso,nb_layer_above_aniso,is_on_a_slice_edge)
-
- ! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
- allocate (perm_layer(ifirst_region:ilast_region))
- 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
-
- ! crustal layer stretching: element layer's top and bottom radii will get stretched when in crust
- ! (number of element layers in crust can vary for different resolutions and 1chunk simulations)
- allocate(stretch_tab(2,ner(1)))
- if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
- ! stretching function determines top and bottom of each element layer in the
- ! crust region (between r_top(1) and r_bottom(1)), where ner(1) is the
- ! number of element layers in this crust region
-
- ! differentiate between regional meshes or global meshes
- if( REGIONAL_MOHO_MESH ) then
- call stretching_function_regional(r_top(1),r_bottom(1),ner(1),stretch_tab)
- else
- call stretching_function(r_top(1),r_bottom(1),ner(1),stretch_tab)
- endif
-
- ! RMIDDLE_CRUST so far is only used for 1D - models with two layers in the crust
- ! (i.e. ONE_CRUST is set to .false.), those models do not use CASE_3D
-
- ! all 3D models use this stretching function to honor a 3D crustal model
- ! for those models, we set RMIDDLE_CRUST to the bottom of the first element layer
- ! this value will be used in moho_stretching.f90 to decide whether or not elements
- ! have to be stretched under oceanic crust.
- !
- ! note: stretch_tab uses (dimensionalized) radii from r_top and r_bottom
- !(with stretch_tab( index_radius(1=top,2=bottom), index_layer( 1=first layer, 2=second layer, 3= ...) )
- RMIDDLE_CRUST = stretch_tab(2,1)
-
- endif
-
-!----
-!---- creates mesh elements
-!----
-
- ! loop on all the layers in this region of the mesh
- ispec = 0 ! counts all the elements 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
- call create_regular_elements(myrank,ilayer,ichunk,ispec,ipass, &
- ifirst_region,ilast_region,iregion_code, &
- nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
- NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- ner_without_doubling,ner,ratio_sampling_array,r_top,r_bottom, &
- xstore,ystore,zstore, &
- iaddx,iaddy,iaddz,xigll,yigll,zigll, &
- shape3D,dershape2D_bottom, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- rmin,rmax,r_moho,r_400,r_670, &
- rhostore,dvpstore,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, &
- nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore,&
- nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
- ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
- nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
- rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB, &
- stretch_tab,ACTUALLY_STORE_ARRAYS, &
- NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
- 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)
-
-
- ! mesh doubling elements
- if( this_region_has_a_doubling(ilayer) ) &
- call create_doubling_elements(myrank,ilayer,ichunk,ispec,ipass, &
- ifirst_region,ilast_region,iregion_code, &
- nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
- NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- ner,ratio_sampling_array,r_top,r_bottom, &
- xstore,ystore,zstore,xigll,yigll,zigll, &
- shape3D,dershape2D_bottom, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- rmin,rmax,r_moho,r_400,r_670, &
- rhostore,dvpstore,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, &
- nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore,&
- nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
- ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
- nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
- rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB,ACTUALLY_STORE_ARRAYS, &
- NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
- 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, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta)
-
- enddo !ilayer_loop
-
- ! define central cube in inner core
- if(INCLUDE_CENTRAL_CUBE .and. iregion_code == IREGION_INNER_CORE) &
- call create_central_cube(myrank,ichunk,ispec,iaddx,iaddy,iaddz, &
- nspec,NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,R_CENTRAL_CUBE, &
- iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,ratio_divide_central_cube, &
- iMPIcut_xi,iMPIcut_eta,iboun, &
- idoubling,iregion_code,xstore,ystore,zstore, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME,&
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- shape3D,rmin,rmax,rhostore,dvpstore,&
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore,nspec_actually, &
- 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
- rho_vp,rho_vs,ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS,xigll,yigll,zigll)
-
-
- ! check total number of spectral elements created
- if(ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec')
-
-! if any of these flags is true, the element is on a communication edge
-! this is not enough because it can also be in contact by an edge or a corner but not a full face
-! therefore we will have to fix array "is_on_a_slice_edge" later in the solver to take this into account
- is_on_a_slice_edge(:) = &
- iMPIcut_xi(1,:) .or. iMPIcut_xi(2,:) .or. &
- iMPIcut_eta(1,:) .or. iMPIcut_eta(2,:) .or. &
- iboun(1,:) .or. iboun(2,:) .or. &
- iboun(3,:) .or. iboun(4,:) .or. &
- iboun(5,:) .or. iboun(6,:)
-
-! no need to count fictitious elements on the edges
-! for which communications cannot be overlapped with calculations
- where(idoubling == IFLAG_IN_FICTITIOUS_CUBE) is_on_a_slice_edge = .false.
-
- ! only create global addressing and the MPI buffers in the first pass
- if(ipass == 1) then
-
- !uncomment: adds model smoothing for point profile models
- ! if( THREE_D_MODEL == THREE_D_MODEL_PPM ) then
- ! call smooth_model(myrank, nproc_xi,nproc_eta,&
- ! rho_vp,rho_vs,nspec_stacey, &
- ! iregion_code,xixstore,xiystore,xizstore, &
- ! etaxstore,etaystore,etazstore, &
- ! gammaxstore,gammaystore,gammazstore, &
- ! xstore,ystore,zstore,rhostore,dvpstore, &
- ! kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
- ! nspec,HETEROGEN_3D_MANTLE, &
- ! NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
-
- ! allocate memory for arrays
- allocate(locval(npointot),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(ifseg(npointot),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(xp(npointot),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(yp(npointot),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(zp(npointot),stat=ier); if(ier /= 0) stop 'error in allocate'
-
- 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) stop 'error in deallocate'
- deallocate(yp,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(zp,stat=ier); if(ier /= 0) stop 'error in deallocate'
-
- ! 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')
-
- ! creates a new indirect addressing to reduce cache misses in memory access in the solver
- ! this is *critical* to improve performance in the solver
- call get_global_indirect_addressing(nspec,nglob,ibool)
-
- ! checks again
- 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,prname,nspec,iMPIcut_xi,ibool, &
- xstore,ystore,zstore,ifseg,npointot, &
- NSPEC2D_ETA_FACE,iregion_code)
-
- call get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
- xstore,ystore,zstore,ifseg,npointot, &
- NSPEC2D_XI_FACE,iregion_code)
-
- call get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool,idoubling, &
- xstore,ystore,zstore,ifseg,npointot, &
- NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion_code)
-
- ! Stacey
- if(NCHUNKS /= 6) &
- call get_absorb(myrank,prname,iboun,nspec,nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
-
- ! create AVS or DX mesh data for the slices
- if(SAVE_MESH_FILES) then
- call write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-
- call write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
- idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
-
- call write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun,ibool, &
- idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
-
- call write_AVS_DX_surface_data(myrank,prname,nspec,iboun,ibool, &
- idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
-
- !> Hejun
- ! Output material information for all GLL points
- ! Can be use to check the mesh
- ! call write_AVS_DX_global_data_gll(prname,nspec,xstore,ystore,zstore,&
- ! rhostore,kappavstore,muvstore,Qmu_store,ATTENUATION)
- endif
-
- deallocate(locval,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(ifseg,stat=ier); if(ier /= 0) stop 'error in deallocate'
-
-! 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
- nspec_tiso = count(idoubling(1:nspec) == IFLAG_220_80) + count(idoubling(1:nspec) == IFLAG_80_MOHO)
-
- 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,&
- xigll,yigll,zigll)
-
- ! allocates mass matrix in this slice (will be fully assembled in the solver)
- allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
- ! allocates ocean load mass matrix as well if oceans
- if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
- nglob_oceans = nglob
- else
- ! allocate dummy array if no oceans
- nglob_oceans = 1
- endif
- allocate(rmass_ocean_load(nglob_oceans))
-
- ! creating mass matrix in this slice (will be fully assembled in the solver)
- call create_mass_matrices(myrank,nspec,idoubling,wxgll,wygll,wzgll,ibool, &
- nspec_actually,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- iregion_code,nglob,rmass,rhostore,kappavstore, &
- nglob_oceans,rmass_ocean_load,NSPEC2D_TOP,ibelm_top,jacobian2D_top, &
- xstore,ystore,zstore,RHO_OCEANS)
-
- ! save the binary files
- 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,dvpstore, &
- 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,is_on_a_slice_edge,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,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,OCEANS, &
- tau_s,tau_e_store,Qmu_store,T_c_source,ATTENUATION, &
- size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5),&
- ABSORBING_CONDITIONS,SAVE_MESH_FILES)
-
- deallocate(rmass,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(rmass_ocean_load,stat=ier); if(ier /= 0) stop 'error in deallocate'
-
- ! 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)
- endif
-
- ! compute volume, bottom and top area of that part of the slice
- call crm_compute_volumes(volume_local,area_local_bottom,area_local_top, &
- nspec,wxgll,wygll,wzgll,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- NSPEC2D_BOTTOM,jacobian2D_bottom,NSPEC2D_TOP,jacobian2D_top)
-
-
- else
- stop 'there cannot be more than two passes in mesh creation'
-
- endif ! end of test if first or second pass
-
- deallocate(stretch_tab)
- deallocate(perm_layer)
-
- ! deallocate these arrays after each pass because they have a different size in each pass to save memory
- deallocate(xixstore,xiystore,xizstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(etaxstore,etaystore,etazstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(gammaxstore,gammaystore,gammazstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
-
- ! deallocate arrays
- deallocate(rhostore,dvpstore,kappavstore,kappahstore)
- deallocate(muvstore,muhstore)
- deallocate(eta_anisostore)
- deallocate(c11store)
- deallocate(c12store)
- deallocate(c13store)
- deallocate(c14store)
- deallocate(c15store)
- deallocate(c16store)
- deallocate(c22store)
- deallocate(c23store)
- deallocate(c24store)
- deallocate(c25store)
- deallocate(c26store)
- deallocate(c33store)
- deallocate(c34store)
- deallocate(c35store)
- deallocate(c36store)
- deallocate(c44store)
- deallocate(c45store)
- deallocate(c46store)
- deallocate(c55store)
- deallocate(c56store)
- deallocate(c66store)
- deallocate(iboun)
- deallocate(xigll,yigll,zigll)
- deallocate(wxgll,wygll,wzgll)
- deallocate(shape3D,dershape3D)
- deallocate(shape2D_x,shape2D_y,shape2D_bottom,shape2D_top)
- deallocate(dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top)
- deallocate(ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax)
- deallocate(ibelm_bottom,ibelm_top)
- deallocate(jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax)
- deallocate(jacobian2D_bottom,jacobian2D_top)
- deallocate(normal_xmin,normal_xmax,normal_ymin,normal_ymax)
- deallocate(normal_bottom,normal_top)
- deallocate(iMPIcut_xi,iMPIcut_eta)
- deallocate(nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta)
- deallocate(rho_vp,rho_vs)
- deallocate(Qmu_store)
- deallocate(tau_e_store)
- deallocate(ibelm_moho_top,ibelm_moho_bot)
- deallocate(ibelm_400_top,ibelm_400_bot)
- deallocate(ibelm_670_top,ibelm_670_bot)
- deallocate(normal_moho,normal_400,normal_670)
- deallocate(jacobian2D_moho,jacobian2D_400,jacobian2D_670)
-
- end subroutine create_regions_mesh
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine crm_initialize_layers(myrank,ipass,xigll,yigll,zigll,wxgll,wygll,wzgll, &
- shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- iaddx,iaddy,iaddz,nspec,xstore,ystore,zstore,ibool,idoubling, &
- iboun,iMPIcut_xi,iMPIcut_eta,ispec2D_moho_top,ispec2D_moho_bot, &
- ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
- NEX_PER_PROC_ETA,nex_eta_moho,RMOHO,R400,R670,r_moho,r_400,r_670, &
- ONE_CRUST,NUMBER_OF_MESH_LAYERS,layer_shift, &
- iregion_code,ifirst_region,ilast_region, &
- first_layer_aniso,last_layer_aniso,nb_layer_above_aniso,is_on_a_slice_edge)
-
-! create the different regions of the mesh
-
- implicit none
-
- include "constants.h"
-
- integer :: myrank,ipass
-
- double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
- double precision wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
-
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
-
- double precision shape2D_x(NGNOD2D,NGLLY,NGLLZ),shape2D_y(NGNOD2D,NGLLX,NGLLZ)
- double precision shape2D_bottom(NGNOD2D,NGLLX,NGLLY),shape2D_top(NGNOD2D,NGLLX,NGLLY)
- double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
- double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
-
- integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
-
- integer nspec
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
- integer idoubling(nspec)
-
- logical iboun(6,nspec)
- logical iMPIcut_xi(2,nspec),iMPIcut_eta(2,nspec)
-
- integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot, &
- ispec2D_670_top,ispec2D_670_bot
- integer NEX_PER_PROC_ETA,nex_eta_moho
- double precision RMOHO,R400,R670
- double precision r_moho,r_400,r_670
-
- logical ONE_CRUST
- integer NUMBER_OF_MESH_LAYERS,layer_shift
-
- ! code for the four regions of the mesh
- integer iregion_code,ifirst_region,ilast_region
- integer first_layer_aniso,last_layer_aniso,nb_layer_above_aniso
-
-! this for non blocking MPI
- logical, dimension(nspec) :: is_on_a_slice_edge
-
-! 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)
-
-! 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
-
-! sets number of layers
- 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
-
-! initialize mesh arrays
- 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.
- is_on_a_slice_edge(:) = .false.
-
- ! boundary mesh
- 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
-
- end subroutine crm_initialize_layers
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine crm_compute_volumes(volume_local,area_local_bottom,area_local_top, &
- nspec,wxgll,wygll,wzgll,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- NSPEC2D_BOTTOM,jacobian2D_bottom,NSPEC2D_TOP,jacobian2D_top)
-
- implicit none
-
- include "constants.h"
-
- double precision :: volume_local,area_local_bottom,area_local_top
-
- integer :: nspec
- double precision :: wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
- integer :: NSPEC2D_BOTTOM,NSPEC2D_TOP
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP) :: jacobian2D_top
-
- ! local parameters
- double precision :: weight
- real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- integer :: i,j,k,ispec
-
- ! initializes
- 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
- xixl = xixstore(i,j,k,ispec)
- xiyl = xiystore(i,j,k,ispec)
- xizl = xizstore(i,j,k,ispec)
- etaxl = etaxstore(i,j,k,ispec)
- etayl = etaystore(i,j,k,ispec)
- etazl = etazstore(i,j,k,ispec)
- gammaxl = gammaxstore(i,j,k,ispec)
- gammayl = gammaystore(i,j,k,ispec)
- gammazl = gammazstore(i,j,k,ispec)
-
- 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
-
- 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
-
-
- end subroutine crm_compute_volumes
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/create_regular_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_regular_elements.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_regular_elements.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,287 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine create_regular_elements(myrank,ilayer,ichunk,ispec,ipass, &
- ifirst_region,ilast_region,iregion_code, &
- nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
- NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- ner_without_doubling,ner,ratio_sampling_array,r_top,r_bottom, &
- xstore,ystore,zstore, &
- iaddx,iaddy,iaddz,xigll,yigll,zigll, &
- shape3D,dershape2D_bottom, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- rmin,rmax,r_moho,r_400,r_670, &
- rhostore,dvpstore,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, &
- nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore,&
- nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
- ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
- nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
- rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB, &
- stretch_tab,ACTUALLY_STORE_ARRAYS, &
- NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
- 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)
-
-
-! adds a regular spectral element to the different regions of the mesh
-
- use meshfem3D_models_par
-
- implicit none
-
- integer :: myrank,ilayer,ichunk,ispec,ipass,ifirst_region,ilast_region
- ! code for the four regions of the mesh
- integer iregion_code
- ! correct number of spectral elements in each block depending on chunk type
- integer nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS
- integer NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
-
- integer :: ner_without_doubling
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
-
-! 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)
-
-! topology of the elements
- integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
-
-! Gauss-Lobatto-Legendre points and weights of integration
- double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
-
-! 3D shape functions and their derivatives
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
-
-! 2D shape functions and their derivatives
- double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
-
- logical INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
-
- double precision RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
-
-! parameters needed to store the radii of the grid points in the spherically symmetric Earth
- double precision rmin,rmax
- double precision r_moho,r_400,r_670
-
-! for model density and anisotropy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
-
-! the 21 coefficients for an anisotropic medium in reduced notation
- integer nspec_ani
- 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
-
-! arrays with mesh parameters
- integer nspec_actually
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
-! Stacey, indices for Clayton-Engquist absorbing conditions
- integer nspec_stacey
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
-
-! boundary locator
- logical iboun(6,nspec)
-
-! MPI cut-planes parameters along xi and along eta
- logical, dimension(2,nspec) :: iMPIcut_xi,iMPIcut_eta
-
- double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
- integer iproc_xi,iproc_eta
-
-! attenuation
- integer nspec_att
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
- double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
- double precision, dimension(N_SLS) :: tau_s
- double precision T_c_source
-
-! rotation matrix from Euler angles
- double precision, dimension(NDIM,NDIM) :: rotation_matrix
-
- integer idoubling(nspec)
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- logical :: USE_ONE_LAYER_SB
-
- double precision, dimension(2,ner(1)) :: stretch_tab
-
- logical :: ACTUALLY_STORE_ARRAYS
-
-! Boundary Mesh
- integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
- integer ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO)
- integer ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400)
- integer ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670)
- real(kind=CUSTOM_REAL) normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO)
- real(kind=CUSTOM_REAL) normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400)
- real(kind=CUSTOM_REAL) normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670)
- real(kind=CUSTOM_REAL) jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO)
- real(kind=CUSTOM_REAL) jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400)
- real(kind=CUSTOM_REAL) jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670)
-
- integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top, &
- ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot
-
- ! local parameters
- double precision, dimension(NGNOD) :: offset_x,offset_y,offset_z
- double precision, dimension(NGNOD) :: xelm,yelm,zelm
- double precision :: r1,r2,r3,r4,r5,r6,r7,r8
- integer :: ix_elem,iy_elem,iz_elem,ignod,ispec_superbrick
- logical :: is_superbrick
-
- ! 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
- 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)*xelm(1)+yelm(1)**2+zelm(1)**2)
- r2=sqrt(xelm(2)*xelm(2)+yelm(2)**2+zelm(2)**2)
- r3=sqrt(xelm(3)*xelm(3)+yelm(3)**2+zelm(3)**2)
- r4=sqrt(xelm(4)*xelm(4)+yelm(4)**2+zelm(4)**2)
- r5=sqrt(xelm(5)*xelm(5)+yelm(5)**2+zelm(5)**2)
- r6=sqrt(xelm(6)*xelm(6)+yelm(6)**2+zelm(6)**2)
- r7=sqrt(xelm(7)*xelm(7)+yelm(7)**2+zelm(7)**2)
- r8=sqrt(xelm(8)*xelm(8)+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,myrank,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore,nspec_actually, &
- 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
- rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
- xigll,yigll,zigll)
-
- ! 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
-
- end subroutine create_regular_elements
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/create_serial_name_database.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_serial_name_database.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_serial_name_database.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine create_serial_name_database(prname,iproc,iregion_code, &
- LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
-
-! create name of the database for serial codes (AVS_DX and codes to check buffers)
-
- implicit none
-
- include "constants.h"
-
- integer iproc,iregion_code,NPROCTOT
-
-! name of the database file
- character(len=150) prname,procname,base_path,serial_prefix, &
- LOCAL_PATH,OUTPUT_FILES
-
- integer iprocloop
- integer, dimension(:), allocatable :: num_active_proc
-
-! create the name for the database of the current slide and region
- write(procname,"('/proc',i6.6,'_reg',i1,'_')") iproc,iregion_code
-
-! on a machine with local disks, path on frontend can be different from local paths
- if(.not. LOCAL_PATH_IS_ALSO_GLOBAL) then
-
-! allocate array for active processors
- allocate(num_active_proc(0:NPROCTOT-1))
-
-! read filtered file with name of active machines
- open(unit=48,file=trim(OUTPUT_FILES)//'/filtered_machines.txt',status='old',action='read')
- do iprocloop = 0,NPROCTOT-1
- read(48,*) num_active_proc(iprocloop)
- enddo
- close(48)
-
-! create the serial prefix pointing to the correct machine
- write(serial_prefix,"('/auto/scratch_n',i6.6,'/')") num_active_proc(iproc)
-
-! suppress everything until the last "/" to define the base name of local path
-! this is system dependent since it assumes the disks are mounted remotely
- base_path = LOCAL_PATH(index(LOCAL_PATH,'/',.true.)+1:len_trim(LOCAL_PATH))
-
-! create full name with path
- prname = trim(serial_prefix) // trim(base_path) // procname
-
-! deallocate array
- deallocate(num_active_proc)
-
-! on shared-memory machines, global path is the same as local path
- else
-
-! create full name with path
- prname = trim(LOCAL_PATH) // procname
-
- endif
-
- end subroutine create_serial_name_database
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/define_derivation_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/define_derivation_matrices.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/define_derivation_matrices.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/define_superbrick.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/define_superbrick.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/define_superbrick.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,2042 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! 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/euler_angles.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/euler_angles.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/euler_angles.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! compute the 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/exit_mpi.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/exit_mpi.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/exit_mpi.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,107 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! 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
-! note: MPI_ABORT does not return, and does exit the
-! program with an error code of 30
- call MPI_ABORT(MPI_COMM_WORLD,30,ier)
-
-! otherwise: there is no standard behaviour to exit with an error code in fortran,
-! however most compilers do recognize this as an error code stop statement;
-! to check stop code in terminal: > echo $?
- stop 30
-
- ! or just exit with message:
- !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/fix_non_blocking_flags.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/fix_non_blocking_flags.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/fix_non_blocking_flags.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! fix the non blocking arrays to assemble the slices inside each chunk: elements
-! in contact with the MPI faces by an edge or a corner only but not
-! a full face are missing, therefore let us add them
- subroutine fix_non_blocking_slices(is_on_a_slice_edge,iboolright_xi, &
- iboolleft_xi,iboolright_eta,iboolleft_eta, &
- npoin2D_xi,npoin2D_eta,ibool, &
- mask_ibool,nspec,nglob,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX)
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,nglob,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
-
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
-
- logical, dimension(nspec) :: is_on_a_slice_edge
-
- integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
- integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
- logical, dimension(nglob) :: mask_ibool
-
- integer :: ipoin,ispec,i,j,k
-
-! clean the mask
- mask_ibool(:) = .false.
-
-! mark all the points that are in the MPI buffers to assemble inside each chunk
- do ipoin = 1,npoin2D_xi(1)
- mask_ibool(iboolleft_xi(ipoin)) = .true.
- enddo
-
- do ipoin = 1,npoin2D_eta(1)
- mask_ibool(iboolleft_eta(ipoin)) = .true.
- enddo
-
- do ipoin = 1,npoin2D_xi(2)
- mask_ibool(iboolright_xi(ipoin)) = .true.
- enddo
-
- do ipoin = 1,npoin2D_eta(2)
- mask_ibool(iboolright_eta(ipoin)) = .true.
- enddo
-
-! now label all the elements that have at least one corner belonging
-! to any of these buffers as elements that must contribute to the
-! first step of the calculations (performed on the edges before starting
-! the non blocking communications); there is no need to examine the inside
-! of the elements, checking their eight corners is sufficient
- do ispec = 1,nspec
- do k = 1,NGLLZ,NGLLZ-1
- do j = 1,NGLLY,NGLLY-1
- do i = 1,NGLLX,NGLLX-1
- if(mask_ibool(ibool(i,j,k,ispec))) then
- is_on_a_slice_edge(ispec) = .true.
- goto 888
- endif
- enddo
- enddo
- enddo
- 888 continue
- enddo
-
- end subroutine fix_non_blocking_slices
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
-! fix the non blocking arrays to assemble the central cube: elements
-! in contact with the MPI faces by an edge or a corner only but not
-! a full face are missing, therefore let us add them
- subroutine fix_non_blocking_central_cube(is_on_a_slice_edge, &
- ibool,nspec,nglob,nb_msgs_theor_in_cube,ibelm_bottom_inner_core, &
- idoubling_inner_core,npoin2D_cube_from_slices,ibool_central_cube,NSPEC2D_BOTTOM_INNER_CORE,ichunk)
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,nglob,nb_msgs_theor_in_cube,NSPEC2D_BOTTOM_INNER_CORE,ichunk,npoin2D_cube_from_slices
-
- logical, dimension(nspec) :: is_on_a_slice_edge
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
- integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices) :: ibool_central_cube
-
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
-
-! local to global mapping
- integer, dimension(nspec) :: idoubling_inner_core
-
-! this mask is declared as integer in the calling program because it is used elsewhere
-! to store integers, and it is reused here as a logical to save memory
- logical, dimension(nglob) :: mask_ibool
-
- integer :: ipoin,ispec,i,j,k,imsg,ispec2D
-
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
- do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
- ispec = ibelm_bottom_inner_core(ispec2D)
- is_on_a_slice_edge(ispec) = .true.
- enddo
- endif
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
- do ispec = 1,nspec
- if(idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
- idoubling_inner_core(ispec) == IFLAG_TOP_CENTRAL_CUBE) &
- is_on_a_slice_edge(ispec) = .true.
- enddo
- endif
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
-! clean the mask
- mask_ibool(:) = .false.
-
- do imsg = 1,nb_msgs_theor_in_cube
- do ipoin = 1,npoin2D_cube_from_slices
- mask_ibool(ibool_central_cube(imsg,ipoin)) = .true.
- enddo
- enddo
-
-! now label all the elements that have at least one corner belonging
-! to any of these buffers as elements that must contribute to the
-! first step of the calculations (performed on the edges before starting
-! the non blocking communications); there is no need to examine the inside
-! of the elements, checking their eight corners is sufficient
- do ispec = 1,nspec
- do k = 1,NGLLZ,NGLLZ-1
- do j = 1,NGLLY,NGLLY-1
- do i = 1,NGLLX,NGLLX-1
- if(mask_ibool(ibool(i,j,k,ispec))) then
- is_on_a_slice_edge(ispec) = .true.
- goto 888
- endif
- enddo
- enddo
- enddo
- 888 continue
- enddo
-
- endif
-
- end subroutine fix_non_blocking_central_cube
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_1D_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_1D_buffers.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_1D_buffers.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,286 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
- idoubling,xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion)
-
-! routine to create the MPI 1D chunk buffers for edges
-
- implicit none
-
- include "constants.h"
-
- integer nspec,myrank,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
-
-! processor identification
- character(len=150) prname
-
-! 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
- 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
- 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
- ! 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
- write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
- endif
- enddo
- endif
- enddo
-
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
- write(10,*) npoin1D
-
- 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
- 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
- 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
- ! 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
- write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
- endif
- enddo
- endif
- enddo
-
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
- write(10,*) npoin1D
-
- 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
- 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
- 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
-
-! 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
- write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
- endif
- enddo
- endif
- enddo
-
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
- write(10,*) npoin1D
-
- 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
- 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
- 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
-
-! 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
- write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
- endif
- enddo
- endif
- enddo
-
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
- write(10,*) npoin1D
-
- 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')
-
- end subroutine get_MPI_1D_buffers
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_eta.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_eta.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_eta.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,168 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
- xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC2D_XI_FACE,iregion)
-
-! 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 nspec,myrank,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
-
-! processor identification
- character(len=150) prname
-
-! 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
- 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
- write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
- endif
- enddo
- enddo
- endif
- enddo
-
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
- write(10,*) npoin2D_eta
-
- 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
- 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
- write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
- endif
- enddo
- enddo
- endif
- enddo
-
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
- write(10,*) npoin2D_eta
-
- 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')
-
- end subroutine get_MPI_cutplanes_eta
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_xi.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_xi.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_xi.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, &
- xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC2D_ETA_FACE,iregion)
-
-! 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 nspec,myrank,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
- integer ier
-
-! processor identification
- character(len=150) prname,errmsg
-
-! 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
- open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_xi.txt', &
- status='unknown',iostat=ier)
- if( ier /= 0 ) then
- if( myrank == 0 ) then
- write(IMAIN,*)
- write(IMAIN,*) 'error creating file: '
- write(IMAIN,*) prname(1:len_trim(prname))//'iboolleft_xi.txt'
- write(IMAIN,*)
- write(IMAIN,*) 'please make sure that the directory specified in Par_file as LOCAL_PATH exists'
- write(IMAIN,*)
- endif
- call exit_mpi(myrank,'error creating iboolleft_xi.txt, please check your Par_file LOCAL_PATH setting')
- endif
-! 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
- write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
- endif
- enddo
- enddo
- endif
- enddo
-
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
- write(10,*) npoin2D_xi
-
- 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
- open(unit=10,file=prname(1:len_trim(prname))//'iboolright_xi.txt', &
- status='unknown',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error creating iboolright_xi.txt for this process')
-
-! 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
- write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
- endif
- enddo
- enddo
- endif
- enddo
-
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
-
-! write total number of points
- write(10,*) npoin2D_xi
-
- 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
-
- end subroutine get_MPI_cutplanes_xi
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_absorb.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_absorb.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_absorb.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,144 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine get_absorb(myrank,prname,iboun,nspec, &
- nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
-
-! Stacey, define flags for absorbing boundaries
-
- implicit none
-
- include "constants.h"
-
- integer nspec,myrank
-
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
-
- integer nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX)
- integer njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX)
- integer nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX)
-
- logical iboun(6,nspec)
-
-! global element numbering
- integer ispecg
-
-! counters to keep track of the number of elements on each of the
-! five absorbing boundaries
- integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5
-
-! processor identification
- character(len=150) prname
-
- ispecb1=0
- ispecb2=0
- ispecb3=0
- ispecb4=0
- ispecb5=0
-
- do ispecg=1,nspec
-
-! determine if the element falls on an absorbing boundary
-
- if(iboun(1,ispecg)) then
-
-! on boundary 1: xmin
- ispecb1=ispecb1+1
-
-! this is useful even if it is constant because it can be zero inside the slices
- njmin(1,ispecb1)=1
- njmax(1,ispecb1)=NGLLY
-
-! check for ovelap with other boundaries
- nkmin_xi(1,ispecb1)=1
- if(iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2
- endif
-
- if(iboun(2,ispecg)) then
-
-! on boundary 2: xmax
- ispecb2=ispecb2+1
-
-! this is useful even if it is constant because it can be zero inside the slices
- njmin(2,ispecb2)=1
- njmax(2,ispecb2)=NGLLY
-
-! check for ovelap with other boundaries
- nkmin_xi(2,ispecb2)=1
- if(iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2
- endif
-
- if(iboun(3,ispecg)) then
-
-! on boundary 3: ymin
- ispecb3=ispecb3+1
-
-! check for ovelap with other boundaries
- nimin(1,ispecb3)=1
- if(iboun(1,ispecg)) nimin(1,ispecb3)=2
- nimax(1,ispecb3)=NGLLX
- if(iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1
- nkmin_eta(1,ispecb3)=1
- if(iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2
- endif
-
- if(iboun(4,ispecg)) then
-
-! on boundary 4: ymax
- ispecb4=ispecb4+1
-
-! check for ovelap with other boundaries
- nimin(2,ispecb4)=1
- if(iboun(1,ispecg)) nimin(2,ispecb4)=2
- nimax(2,ispecb4)=NGLLX
- if(iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1
- nkmin_eta(2,ispecb4)=1
- if(iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2
- endif
-
-! on boundary 5: bottom
- if(iboun(5,ispecg)) ispecb5=ispecb5+1
-
- enddo
-
-! check theoretical value of elements at the bottom
- if(ispecb5 /= NSPEC2D_BOTTOM) &
- call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM in absorbing boundary detection')
-
-! save these temporary arrays for the solver for Stacey conditions
- open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin',status='unknown',form='unformatted',action='write')
- write(27) nimin
- write(27) nimax
- write(27) njmin
- write(27) njmax
- write(27) nkmin_xi
- write(27) nkmin_eta
- close(27)
-
- end subroutine get_absorb
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_attenuation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_attenuation.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_attenuation.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,721 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
- subroutine 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))//'attenuation.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 get_attenuation_property_values(tau_s, tau_e, fc, omsb)
-
- factor_common(:,i,j,k,ispec) = fc(:)
- one_minus_sum_beta(i,j,k,ispec) = omsb
-
- ! Determine the "scale_factor" from tau_s, tau_e, central source frequency, and Q
- call get_attenuation_scale_factor(myrank, T_c_source, tau_e, tau_s, Q_mu, sf)
- scale_factor(i,j,k,ispec) = sf
- enddo
- enddo
- enddo
- enddo
-
- end subroutine get_attenuation_model_3D
-
-!
-!-------------------------------------------------------------------------------------------------
-!
- subroutine get_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 get_attenuation_property_values
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine get_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.8 .or. scale_factor > 1.2) then
- write(*,*)'scale factor: ', scale_factor
- call exit_MPI(myrank,'incorrect correction factor in attenuation model')
- endif
-
- end subroutine get_attenuation_scale_factor
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine get_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 get_attenuation_memory_values
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-! not used anymore...
-!
-! 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'
-!
-!! model_attenuation_variables
-! type model_attenuation_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
-! integer dummy_pad ! padding 4 bytes to align the structure
-! end type model_attenuation_variables
-!
-! type (model_attenuation_variables) AM_V
-!! model_attenuation_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
-!
-!
-!-------------------------------------------------------------------------------------------------
-!
-!
-!-------------------------------------------------------------------------------------------------
-!
-! not used anymore...
-!
-! 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
-!
-!
-!-------------------------------------------------------------------------------------------------
-!
-! not used anymore...
-!
-! 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
-!
-!
-!-------------------------------------------------------------------------------------------------
-!
-! not used anymore...
-!
-! 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
-!
-!
-!-------------------------------------------------------------------------------------------------
-!
-!
-! not used anymore...
-!
-! 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
-!
-!
-!-------------------------------------------------------------------------------------------------
-!
-! not used anymore...
-!
-! subroutine attenuation_save_arrays(prname, iregion_code, AM_V)
-!
-! implicit none
-!
-! include 'mpif.h'
-! include 'constants.h'
-!
-!! model_attenuation_variables
-! type model_attenuation_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 model_attenuation_variables
-!
-! type (model_attenuation_variables) AM_V
-!! model_attenuation_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
-!
-!
-!-------------------------------------------------------------------------------------------------
-!
-! not used anymore...
-!
-! subroutine get_attenuation_index(iflag, radius, index, inner_core, AM_V)
-!
-! implicit none
-!
-! include 'constants.h'
-!
-!! model_attenuation_variables
-! type model_attenuation_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 model_attenuation_variables
-!
-! type (model_attenuation_variables) AM_V
-!! model_attenuation_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
-!
-!
-!-------------------------------------------------------------------------------------------------
-!
-! not used anymore...
-!
-! subroutine set_attenuation_regions_1D(RICB, RCMB, R670, R220, R80, AM_V)
-!
-! implicit none
-!
-! include 'constants.h'
-!
-!! model_attenuation_variables
-! type model_attenuation_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 model_attenuation_variables
-!
-! type (model_attenuation_variables) AM_V
-!! model_attenuation_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
-!
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_backazimuth.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_backazimuth.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_backazimuth.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,174 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! get backazimuth baz from event and station coordinates the, phe, ths and phs
- subroutine get_backazimuth(the,phe,ths,phs,baz)
-
- implicit none
-
- double precision the, phe
- double precision ths, phs
- double precision az,baz,xdeg
-
- double precision a, a1, b, b1, c, c1
- double precision d, d1, e, e1
- double precision ec2, eps, f, f1, g, g1, h, h1, onemec2, pherad
- double precision phsrad, sc, sd, ss
- double precision temp, therad, thg, thsrad
-
- double precision, parameter :: rad = 6378.160
- double precision, parameter :: fl = 0.00335293
- double precision, parameter :: twopideg = 360.
- double precision, parameter :: c00 = 1.
- double precision, parameter :: c01 = 0.25
- double precision, parameter :: c02 = -4.6875e-02
- double precision, parameter :: c03 = 1.953125e-02
- double precision, parameter :: c21 = -0.125
- double precision, parameter :: c22 = 3.125e-02
- double precision, parameter :: c23 = -1.46484375e-02
- double precision, parameter :: c42 = -3.90625e-03
- double precision, parameter :: c43 = 2.9296875e-03
- double precision, parameter :: degtokm = 111.3199
- double precision, parameter :: pi = 3.141592654
- double precision, parameter :: TORAD = pi/180.
- double precision, parameter :: TODEG = 1./TORAD
-
-
- !=====================================================================
- ! PURPOSE: To compute the distance and azimuth between locations.
- !=====================================================================
- ! INPUT ARGUMENTS:
- ! THE: Event latitude in decimal degrees, North positive. [r]
- ! PHE: Event longitude, East positive. [r]
- ! THS: Array of station latitudes. [r]
- ! PHS: Array of station longitudes. [r]
- ! NS: Length of THS and PHS. [i]
- !=====================================================================
- ! OUTPUT ARGUMENTS:
- ! DIST: Array of epicentral distances in km. [r]
- ! AZ: Array of azimuths in degrees. [r]
- ! BAZ: Array of back azimuths. [r]
- ! XDEG: Array of great circle arc lengths. [r]
- ! NERR: Error flag:
- ! = 0 No error.
- ! = 0904 Calculation failed internal consistency checks.
- !=====================================================================
- ! MODULE/LEVEL: DFM/4
- !=====================================================================
- ! GLOBAL INPUT:
- ! MACH:
- !=====================================================================
- ! SUBROUTINES CALLED:
- ! SACLIB: SETMSG, APCMSG
- !=====================================================================
- ! LOCAL VARIABLES:
- !=====================================================================
- ! KNOWN ERRORS:
- ! - Problem with equation for distance. See discussion below.
- !=====================================================================
- ! PROCEDURE:
- ! - Calculations are based upon the reference spheroid of 1968 and
- ! are defined by the major radius (RAD) and the flattening (FL).
- ! - Initialize.
- !nerr = 0
-
- ec2 = 2.*fl - fl*fl
- onemec2 = 1. - ec2
- eps = 1. + ec2/onemec2
-
- ! - Convert event location to radians.
- ! (Equations are unstable for latidudes of exactly 0 degrees.)
-
- temp = the
- if( temp == 0. ) temp = 1.0e-08
- therad = TORAD*temp
- pherad = TORAD*phe
-
- ! - Must convert from geographic to geocentric coordinates in order
- ! to use the spherical trig equations. This requires a latitude
- ! correction given by: 1-EC2=1-2*FL+FL*FL
-
- if ( the == 90 .or. the == -90 ) then ! special attention at the poles
- thg = the*TORAD ! ... to avoid division by zero.
- else
- thg = atan( onemec2*tan( therad ) )
- endif
-
- d = sin( pherad )
- e = -cos( pherad )
- f = -cos( thg )
- c = sin( thg )
- a = f*e
- b = -f*d
- g = -c*e
- h = c*d
-
-
- ! -- Convert to radians.
- temp = Ths
- if( temp == 0. ) temp = 1.0e-08
- thsrad = TORAD*temp
- phsrad = TORAD*Phs
-
- ! -- Calculate some trig constants.
- if ( Ths == 90 .or. Ths == -90 ) then
- thg = Ths * TORAD
- else
- thg = atan( onemec2*tan( thsrad ) )
- endif
-
- d1 = sin( phsrad )
- e1 = -cos( phsrad )
- f1 = -cos( thg )
- c1 = sin( thg )
- a1 = f1*e1
- b1 = -f1*d1
- g1 = -c1*e1
- h1 = c1*d1
- sc = a*a1 + b*b1 + c*c1
-
- ! - Spherical trig relationships used to compute angles.
-
- sd = 0.5*sqrt( ((a - a1)**2 + (b - b1)**2 + (c - &
- c1)**2)*((a + a1)**2 + (b + b1)**2 + (c + c1)**2) )
- Xdeg = atan2( sd, sc )*TODEG
- if( Xdeg < 0. ) &
- Xdeg = Xdeg + twopideg
-
- ss = (a1 - d)**2 + (b1 - e)**2 + (c1)**2 - 2.
- sc = (a1 - g)**2 + (b1 - h)**2 + (c1 - f)**2 - 2.
- Az = atan2( ss, sc )*TODEG
- if( Az < 0. ) &
- Az = Az + twopideg
-
- ss = (a - d1)**2 + (b - e1)**2 + (c)**2 - 2.
- sc = (a - g1)**2 + (b - h1)**2 + (c - f1)**2 - 2.
- Baz = atan2( ss, sc )*TODEG
- if( Baz < 0. ) &
- Baz = Baz + twopideg
-
-end subroutine get_backazimuth
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_cmt.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_cmt.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_cmt.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,173 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine get_cmt(yr,jda,ho,mi,sec,tshift_cmt,hdur,lat,long,depth,moment_tensor, &
- DT,NSOURCES,min_tshift_cmt_original)
-
- 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,min_tshift_cmt_original
- double precision, dimension(NSOURCES), intent(out) :: tshift_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
- double precision t_shift(NSOURCES)
- character(len=5) datasource
- character(len=256) string, CMTSOLUTION
-
- ! initializes
- lat(:) = 0.d0
- long(:) = 0.d0
- depth(:) = 0.d0
- t_shift(:) = 0.d0
- tshift_cmt(:) = 0.d0
- hdur(:) = 0.d0
- moment_tensor(:,:) = 0.d0
- yr = 0
- jda = 0
- ho = 0
- mi = 0
- sec = 0.d0
-
-!
-!---- 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(1,"(a256)") string
- ! skips empty lines
- do while( len_trim(string) == 0 )
- read(1,"(a256)") string
- enddo
-
- ! read header with event information
- read(string,"(a4,i5,i3,i3,i3,i3,f6.2)") datasource,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)),*) tshift_cmt(isource)
- read(string(12:len_trim(string)),*) t_shift(isource)
-
- ! read half duration
- read(1,"(a)") string
- read(string(15:len_trim(string)),*) hdur(isource)
-
- ! read latitude
- read(1,"(a)") string
- read(string(10:len_trim(string)),*) lat(isource)
-
- ! read longitude
- read(1,"(a)") string
- read(string(11:len_trim(string)),*) long(isource)
-
- ! read depth
- read(1,"(a)") string
- read(string(7:len_trim(string)),*) depth(isource)
-
- ! read Mrr
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) 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)
-
- ! checks half-duration
- if( USE_FORCE_POINT_SOURCE ) then
- ! half-duration is the dominant frequency of the source
- ! point forces use a Ricker source time function
- ! null half-duration indicates a very low-frequency source
- ! (see constants.h: TINYVAL = 1.d-9 )
- if( hdur(isource) < TINYVAL ) hdur(isource) = TINYVAL
- else
- ! null half-duration indicates a Heaviside
- ! replace with very short error function
- if( hdur(isource) < 5. * DT ) hdur(isource) = 5. * DT
- endif
-
- enddo
-
- close(1)
-
- ! Sets tshift_cmt to zero to initiate the simulation!
- if(NSOURCES == 1)then
- tshift_cmt = 0.d0
- min_tshift_cmt_original = t_shift(1)
- else
- tshift_cmt(1:NSOURCES) = t_shift(1:NSOURCES)-minval(t_shift)
- min_tshift_cmt_original = minval(t_shift)
- endif
-
-!
-! 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_ellipticity.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_ellipticity.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_ellipticity.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,112 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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
-
- !> Hejun
- ! get ellipticity according to GLL points
- ! JAN08, 2010
- subroutine get_ellipticity_gll(xstore,ystore,zstore,ispec,nspec,nspl,rspl,espl,espl2)
-
- implicit none
-
- include "constants.h"
-
- integer nspl
- integer::ispec,nspec
- double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec):: xstore,ystore,zstore
- double precision rspl(NR),espl(NR),espl2(NR)
-
- integer i,j,k
-
- double precision ell
- double precision r,theta,phi,factor
- double precision cost,p20
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- call xyz_2_rthetaphi_dble(xstore(i,j,k,ispec),ystore(i,j,k,ispec),zstore(i,j,k,ispec),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
-
- xstore(i,j,k,ispec)=xstore(i,j,k,ispec)*factor
- ystore(i,j,k,ispec)=ystore(i,j,k,ispec)*factor
- zstore(i,j,k,ispec)=zstore(i,j,k,ispec)*factor
-
- end do
- end do
- end do
- end subroutine get_ellipticity_gll
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_event_info.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_event_info.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_event_info.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,306 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! get information about event name and location for SAC seismograms: MPI version by Dimitri Komatitsch
-
-! Instead of using region names as event names,
-! event names given in the second row of CMT files will be used.
-! Thus, I removed old parameters ename, region, LENGTH_REGION_NAME and added event_name!!!!!!!
-! Also, t_shift is added as a new parameter to be written on sac headers!
-! by Ebru Bozdag
-
- !subroutine get_event_info_parallel(myrank,yr,jda,ho,mi,sec,tshift_cmt, &
- ! elat,elon,depth,mb,ename,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES)
-
- subroutine get_event_info_parallel(myrank,yr,jda,ho,mi,sec,&
- event_name,tshift_cmt,t_shift, &
- elat,elon,depth,mb,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) :: yr,jda,ho,mi
- real, intent(out) :: mb
- double precision, intent(out) :: tshift_cmt,elat,elon,depth,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,sec
-
- !character(len=12), intent(out) :: ename
-
- integer, intent(in) :: NSOURCES ! must be given
- double precision, intent(out) :: t_shift
- character(len=20), intent(out) :: event_name
-
-
-
-!--- local variables below
-
- integer 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,event_name,tshift_cmt,t_shift, &
- elat,elon,depth,mb, &
- cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES)
-
- !call get_event_info_serial(yr,jda,ho,mi,sec,tshift_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(sec,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(tshift_cmt,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(t_shift,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- ! event location given on first, PDE line
- 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)
-
- ! cmt location given in CMT file
- 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)
- call MPI_BCAST(event_name,20,MPI_DOUBLE_PRECISION,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
-
-! This subroutine has been modified to read full CMTSOLUTION file particularly for multiple-source cases.
-! Time-shifts of all sources can be read and the minimum t_shift is taken to be written in sac headers!
-! by Ebru
-
- subroutine get_event_info_serial(yr,jda,ho,mi,sec,event_name,tshift_cmt,t_shift,&
- elat_pde,elon_pde,depth_pde,mb,&
- cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES)
-
-
- !subroutine get_event_info_serial(yr,jda,ho,mi,sec,tshift_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) :: yr,jda,ho,mi
-
- real, intent(out) :: mb
-
- double precision, intent(out) :: sec,tshift_cmt,t_shift
- double precision, intent(out) :: elat_pde,elon_pde,depth_pde,cmt_lat,cmt_lon,cmt_depth,cmt_hdur
-
- !integer, intent(in) :: LENGTH_REGION_NAME
- !character(len=LENGTH_REGION_NAME), intent(out) :: region ! event name for SAC header
-
- character(len=20), intent(out) :: event_name ! event name for SAC header
-
- integer, intent(in) :: NSOURCES
-
-!--- local variables here
-
- integer ios,mo,da,julian_day
- integer isource
-
- double precision, dimension(NSOURCES) :: t_s,hdur,lat,lon,depth
- character(len=20), dimension(NSOURCES) :: e_n
-
- real ms
-
- character(len=5) datasource
- character(len=150) string,CMTSOLUTION
- !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
- ! which is: event_id, date,origin time,latitude,longitude,depth, mb, MS, region
-
- ! read source number isource
- do isource=1,NSOURCES
-
- ! read header with event information
- read(821,*) datasource,yr,mo,da,ho,mi,sec,elat_pde,elon_pde,depth_pde,mb,ms
- jda=julian_day(yr,mo,da)
-
- ! ignore line with event name
- read(821,"(a)") string
- read(string(12:len_trim(string)),*) e_n(isource)
-
- ! read time shift
- read(821,"(a)") string
- read(string(12:len_trim(string)),*) t_s(isource)
-
- ! read half duration
- read(821,"(a)") string
- read(string(15:len_trim(string)),*) hdur(isource)
-
- ! read latitude
- read(821,"(a)") string
- read(string(10:len_trim(string)),*) lat(isource)
-
- ! read longitude
- read(821,"(a)") string
- read(string(11:len_trim(string)),*) lon(isource)
-
- ! read depth
- read(821,"(a)") string
- read(string(7:len_trim(string)),*) depth(isource)
-
- ! ignore the last 6 lines with moment tensor info
- read(821,"(a)") string
- read(821,"(a)") string
- read(821,"(a)") string
- read(821,"(a)") string
- read(821,"(a)") string
- read(821,"(a)") string
- enddo
- ! sets tshift_cmt to zero
- tshift_cmt = 0.
-
- ! takes first event id as event_name
- event_name = e_n(1)
-
- ! sets cmt infos
- if (NSOURCES == 1) then
- cmt_lat = lat(1)
- cmt_lon = lon(1)
- cmt_depth = depth(1)
- cmt_hdur = hdur(1)
- t_shift = t_s(1)
- else
- cmt_lat = -1e8
- cmt_lon = -1e8
- cmt_depth = -1e8
- cmt_hdur = -1e8
- ! takes minimum time shift of all given sources
- t_shift = minval(t_s(1:NSOURCES))
- endif
-
- close(821)
-
-
-
-! ! 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)),*) tshift_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/get_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_global.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_global.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,295 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine get_global_indirect_addressing(nspec,nglob,ibool)
-
-!
-!- we can create a new indirect addressing to reduce cache misses
-! (put into this subroutine but compiler keeps on complaining that it can't vectorize loops...)
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,nglob
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
- ! mask to sort ibool
- integer, dimension(:), allocatable :: mask_ibool
- integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
- integer :: inumber
- integer:: i,j,k,ispec,ier
-
- ! copies original array
- allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(mask_ibool(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
-
- mask_ibool(:) = -1
- copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:)
-
- ! reduces misses
- 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
- ! creates a new point
- inumber = inumber + 1
- ibool(i,j,k,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,k,ispec)) = inumber
- else
- ! uses an existing point created previously
- ibool(i,j,k,ispec) = mask_ibool(copy_ibool_ori(i,j,k,ispec))
- endif
- enddo
- enddo
- enddo
- enddo
-
- ! cleanup
- deallocate(copy_ibool_ori,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(mask_ibool,stat=ier); if(ier /= 0) stop 'error in deallocate'
-
-end subroutine get_global_indirect_addressing
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-! 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/get_jacobian_boundaries.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_boundaries.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_boundaries.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,528 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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,xigll,yigll,zigll)
-
- 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)
-
-! Parameters used to calculate 2D Jacobian based upon 25 GLL points
- integer:: i,j,k
- double precision xelm2D(NGLLX,NGLLY),yelm2D(NGLLX,NGLLY),zelm2D(NGLLX,NGLLY)
- double precision,dimension(NGLLX):: xigll
- double precision,dimension(NGLLY):: yigll
- double precision,dimension(NGLLZ):: zigll
-
-! 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
-
- if ( .not. USE_GLL) then
- ! 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)
- else
- ! get 25 GLL points for xmin
- do k = 1,NGLLZ
- do j = 1,NGLLY
- xelm2D(j,k) = xstore(1,j,k,ispec)
- yelm2D(j,k) = ystore(1,j,k,ispec)
- zelm2D(j,k) = zstore(1,j,k,ispec)
- end do
- end do
- ! recalculate jacobian according to 2D GLL points
- call recalc_jacobian_gll2D(myrank,ispecb1,xelm2D,yelm2D,zelm2D, &
- yigll,zigll,jacobian2D_xmin,normal_xmin,&
- NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- end if
- endif
-
- ! on boundary: xmax
-
- if(iboun(2,ispec)) then
-
- ispecb2=ispecb2+1
- ibelm_xmax(ispecb2)=ispec
-
- if ( .not. USE_GLL) then
- ! 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)
-
- else
- ! get 25 GLL points for xmax
- do k = 1,NGLLZ
- do j = 1,NGLLY
- xelm2D(j,k) = xstore(NGLLX,j,k,ispec)
- yelm2D(j,k) = ystore(NGLLX,j,k,ispec)
- zelm2D(j,k) = zstore(NGLLX,j,k,ispec)
- end do
- end do
- ! recalculate jacobian according to 2D GLL points
- call recalc_jacobian_gll2D(myrank,ispecb2,xelm2D,yelm2D,zelm2D,&
- yigll,zigll,jacobian2D_xmax,normal_xmax,&
- NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- end if
- endif
-
- ! on boundary: ymin
-
- if(iboun(3,ispec)) then
-
- ispecb3=ispecb3+1
- ibelm_ymin(ispecb3)=ispec
-
- if ( .not. USE_GLL) then
- ! 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)
-
- else
- ! get 25 GLL points for ymin
- do k =1 ,NGLLZ
- do i = 1,NGLLX
- xelm2D(i,k) = xstore(i,1,k,ispec)
- yelm2D(i,k) = ystore(i,1,k,ispec)
- zelm2D(i,k) = zstore(i,1,k,ispec)
- end do
- end do
- ! recalcualte 2D jacobian according to GLL points
- call recalc_jacobian_gll2D(myrank,ispecb3,xelm2D,yelm2D,zelm2D,&
- xigll,zigll,jacobian2D_ymin,normal_ymin,&
- NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- end if
- endif
-
- ! on boundary: ymax
-
- if(iboun(4,ispec)) then
-
- ispecb4=ispecb4+1
- ibelm_ymax(ispecb4)=ispec
-
- if ( .not. USE_GLL) then
- ! 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)
-
- else
- ! get 25 GLL points for ymax
- do k =1,NGLLZ
- do i = 1,NGLLX
- xelm2D(i,k) = xstore(i,NGLLY,k,ispec)
- yelm2D(i,k) = ystore(i,NGLLY,k,ispec)
- zelm2D(i,k) = zstore(i,NGLLY,k,ispec)
- end do
- end do
- ! recalculate jacobian for 2D GLL points
- call recalc_jacobian_gll2D(myrank,ispecb4,xelm2D,yelm2D,zelm2D,&
- xigll,zigll,jacobian2D_ymax,normal_ymax,&
- NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- end if
- endif
-
- ! on boundary: bottom
-
- if(iboun(5,ispec)) then
-
- ispecb5=ispecb5+1
- ibelm_bottom(ispecb5)=ispec
-
- if ( .not. USE_GLL) then
- 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)
-
- else
- ! get 25 GLL points for zmin
- do j = 1,NGLLY
- do i = 1,NGLLX
- xelm2D(i,j) = xstore(i,j,1,ispec)
- yelm2D(i,j) = ystore(i,j,1,ispec)
- zelm2D(i,j) = zstore(i,j,1,ispec)
- end do
- end do
- ! recalcuate 2D jacobian according to GLL points
- call recalc_jacobian_gll2D(myrank,ispecb5,xelm2D,yelm2D,zelm2D,&
- xigll,yigll,jacobian2D_bottom,normal_bottom,&
- NGLLX,NGLLY,NSPEC2D_BOTTOM)
- end if
-
- endif
-
- ! on boundary: top
-
- if(iboun(6,ispec)) then
-
- ispecb6=ispecb6+1
- ibelm_top(ispecb6)=ispec
-
- if ( .not. USE_GLL) then
- 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)
- else
- ! get 25 GLL points for zmax
- do j = 1,NGLLY
- do i = 1,NGLLX
- xelm2D(i,j) = xstore(i,j,NGLLZ,ispec)
- yelm2D(i,j) = ystore(i,j,NGLLZ,ispec)
- zelm2D(i,j) = zstore(i,j,NGLLZ,ispec)
- end do
- end do
- ! recalcuate jacobian according to 2D gll points
- call recalc_jacobian_gll2D(myrank,ispecb6,xelm2D,yelm2D,zelm2D,&
- xigll,yigll,jacobian2D_top,normal_top,&
- NGLLX,NGLLY,NSPEC2D_TOP)
-
- end if
-
- endif
-
- enddo
-
-
-! check theoretical value of elements at the bottom
- if(ispecb5 /= NSPEC2D_BOTTOM) then
- print*,'error ispecb5:',ispecb5,NSPEC2D_BOTTOM
- 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_discontinuities.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_discontinuities.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_discontinuities.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,207 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-subroutine get_jacobian_discontinuities(myrank,ispec,ix_elem,iy_elem,rmin,rmax,r1,r2,r3,r4,r5,r6,r7,r8, &
- xstore,ystore,zstore,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)
-
- implicit none
-
- include 'constants.h'
-
- ! input
- integer myrank, ispec, ix_elem, iy_elem
- double precision rmin,rmax
- double precision xstore(NGLLX,NGLLY,NGLLZ)
- double precision ystore(NGLLX,NGLLY,NGLLZ)
- double precision zstore(NGLLX,NGLLY,NGLLZ)
- double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
- integer NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670, nex_eta_moho, ispec_superbrick
- double precision r_moho, r_400, r_670
- logical :: is_superbrick, USE_ONE_LAYER_SB,HONOR_1D_SPHERICAL_MOHO
-
- ! output
- integer ispec2D_moho_top, ispec2D_moho_bot, ispec2D_400_top, ispec2D_400_bot, ispec2D_670_top, ispec2D_670_bot
- integer,dimension(NSPEC2D_MOHO) :: ibelm_moho_top, ibelm_moho_bot
- integer,dimension(NSPEC2D_400) :: ibelm_400_top, ibelm_400_bot
- integer,dimension(NSPEC2D_670) :: ibelm_670_top, ibelm_670_bot
- real(kind=CUSTOM_REAL) :: normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO), jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO)
- real(kind=CUSTOM_REAL) :: normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400), jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400)
- real(kind=CUSTOM_REAL) :: normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670), jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670)
-
- ! local variables
- double precision, dimension(NGNOD2D) :: xelm2, yelm2, zelm2
- double precision :: r1, r2, r3, r4, r5, r6, r7, r8
- double precision :: target_moho_high, target_moho_low, target_400_high, target_400_low, target_670_high, target_670_low
- integer :: nele_sub_block, ispec_list(16), map_irem_ix_12(8), map_irem_ix_34(8), map_irem_iy_odd(8), map_irem_iy_even(8)
- integer :: map_isub_ix(4), map_isub_iy(4), map_ix(NSPEC_DOUBLING_SUPERBRICK), map_iy(NSPEC_DOUBLING_SUPERBRICK)
- integer :: i, ispec_superbrick_current, isub_block, irem_block, irem_ix, irem_iy, ix,iy,ix_top,iy_top, ispec2D_moho_bot_map
-
- ! ======================
-
-
- ! find the coordinates of 9 nodes for the bottom surface element to compute the jacobian if needed
- xelm2(1)=xstore(1,1,1)
- yelm2(1)=ystore(1,1,1)
- zelm2(1)=zstore(1,1,1)
- xelm2(2)=xstore(NGLLX,1,1)
- yelm2(2)=ystore(NGLLX,1,1)
- zelm2(2)=zstore(NGLLX,1,1)
- xelm2(3)=xstore(NGLLX,NGLLY,1)
- yelm2(3)=ystore(NGLLX,NGLLY,1)
- zelm2(3)=zstore(NGLLX,NGLLY,1)
- xelm2(4)=xstore(1,NGLLY,1)
- yelm2(4)=ystore(1,NGLLY,1)
- zelm2(4)=zstore(1,NGLLY,1)
- xelm2(5)=xstore((NGLLX+1)/2,1,1)
- yelm2(5)=ystore((NGLLX+1)/2,1,1)
- zelm2(5)=zstore((NGLLX+1)/2,1,1)
- xelm2(6)=xstore(NGLLX,(NGLLY+1)/2,1)
- yelm2(6)=ystore(NGLLX,(NGLLY+1)/2,1)
- zelm2(6)=zstore(NGLLX,(NGLLY+1)/2,1)
- xelm2(7)=xstore((NGLLX+1)/2,NGLLY,1)
- yelm2(7)=ystore((NGLLX+1)/2,NGLLY,1)
- zelm2(7)=zstore((NGLLX+1)/2,NGLLY,1)
- xelm2(8)=xstore(1,(NGLLY+1)/2,1)
- yelm2(8)=ystore(1,(NGLLY+1)/2,1)
- zelm2(8)=zstore(1,(NGLLY+1)/2,1)
- xelm2(9)=xstore((NGLLX+1)/2,(NGLLY+1)/2,1)
- yelm2(9)=ystore((NGLLX+1)/2,(NGLLY+1)/2,1)
- zelm2(9)=zstore((NGLLX+1)/2,(NGLLY+1)/2,1)
-
-! radii to determine if an element is on the discontinuity or not
- target_moho_high = r_moho * (ONE + SMALLVAL)
- target_moho_low = r_moho * (ONE - SMALLVAL)
- target_400_high = r_400 * (ONE + SMALLVAL)
- target_400_low = r_400 * (ONE - SMALLVAL)
- target_670_high = r_670 * (ONE + SMALLVAL)
- target_670_low = r_670 * (ONE - SMALLVAL)
-
-! setup the mapping array for superbrick case (only invoked for Moho bottom)
- if (is_superbrick) then
- map_irem_ix_12=(/2,2,0,1,0,1,0,0/)
- map_irem_ix_34=(/1,1,0,2,0,2,0,0/)
- map_irem_iy_odd=(/1,2,0,1,0,2,0,0/)
- map_irem_iy_even=(/2,1,0,2,0,1,0,0/)
- if (USE_ONE_LAYER_SB) then
- nele_sub_block = 7
- ispec_list=(/1,2,4,6,8,9,11,13,15,16,18,20,22,23,25,27/)
- else
- nele_sub_block = 8
- ispec_list=(/1,2,4,6,9,10,12,14,17,18,20,22,25,26,28,30/)
- endif
- map_isub_ix=(/2,2,1,1/)
- map_isub_iy=(/2,1,2,1/)
-
- map_ix(1:NSPEC_DOUBLING_SUPERBRICK) = 0
- map_iy(1:NSPEC_DOUBLING_SUPERBRICK) = 0
-
- do i = 1, 16
- ispec_superbrick_current=ispec_list(i)
- isub_block = ispec_superbrick_current/nele_sub_block + 1
- irem_block = mod(ispec_superbrick_current,nele_sub_block)
-
- if (isub_block > 2) then
- irem_ix = map_irem_ix_34(irem_block)
- else
- irem_ix = map_irem_ix_12(irem_block)
- endif
- if (mod(isub_block,2) == 0) then
- irem_iy = map_irem_iy_even(irem_block)
- else
- irem_iy = map_irem_iy_odd(irem_block)
- endif
- map_ix(ispec_list(i)) = (map_isub_ix(isub_block) - 1) * 2 + irem_ix
- map_iy(ispec_list(i)) = (map_isub_iy(isub_block) - 1) * 2 + irem_iy
-! if (ispec_superbrick == 1 .and. myrank == 0) &
-! write(*,'(10i4)') i, ispec_list(i), map_ix(ispec_list(i)), map_iy(ispec_list(i))
- enddo
- endif
-
-! determine if the elements are on the discontinuity, and calculate the boundary jaocobian if needed
- if (.not. is_superbrick) then
-
-! Moho top
- if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO .and. &
- abs(rmin-r_moho)/r_moho < SMALLVAL .and. r1 < target_moho_high .and. r2 < target_moho_high &
- .and. r3 < target_moho_high .and. r4 < target_moho_high) then
- ispec2D_moho_top = ispec2D_moho_top + 1
- ibelm_moho_top(ispec2D_moho_top) = ispec
- call compute_jacobian_2D(myrank,ispec2D_moho_top,xelm2,yelm2,zelm2,dershape2D_bottom, &
- jacobian2D_moho,normal_moho,NGLLX,NGLLY,NSPEC2D_MOHO)
-! 400 top
- else if (abs(rmin-r_400)/r_400 < SMALLVAL .and. r1 < target_400_high .and. r2 < target_400_high &
- .and. r3 < target_400_high .and. r4 < target_400_high) then
- ispec2D_400_top = ispec2D_400_top + 1
- ibelm_400_top(ispec2D_400_top) = ispec
- call compute_jacobian_2D(myrank,ispec2D_400_top,xelm2,yelm2,zelm2,dershape2D_bottom, &
- jacobian2D_400,normal_400,NGLLX,NGLLY,NSPEC2D_400)
-
-! 400 bot
- else if (abs(rmax-r_400)/r_400 < SMALLVAL .and. r5 > target_400_low .and. r6 > target_400_low &
- .and. r7 > target_400_low .and. r8 > target_400_low) then
- ispec2D_400_bot = ispec2D_400_bot + 1
- ibelm_400_bot(ispec2D_400_bot) = ispec
-
-! 670 top
- else if (abs(rmin-r_670)/r_670 < SMALLVAL .and. r1 < target_670_high .and. r2 < target_670_high &
- .and. r3 < target_670_high .and. r4 < target_670_high) then
- ispec2D_670_top = ispec2D_670_top + 1
- ibelm_670_top(ispec2D_670_top) = ispec
- call compute_jacobian_2D(myrank,ispec2D_670_top,xelm2,yelm2,zelm2,dershape2D_bottom, &
- jacobian2D_670,normal_670,NGLLX,NGLLY,NSPEC2D_670)
-! 670 bot
- else if (abs(rmax-r_670)/r_670 < SMALLVAL .and. r5 > target_670_low .and. r6 > target_670_low &
- .and. r7 > target_670_low .and. r8 > target_670_low) then
- ispec2D_670_bot = ispec2D_670_bot + 1
- ibelm_670_bot(ispec2D_670_bot) = ispec
- endif
-
- else ! superbrick case
- ! Moho bot (special care should be taken to deal with mapping 2D element indices)
- if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO .and. &
- abs(rmax-r_moho)/r_moho < SMALLVAL .and. r5 > target_moho_low .and. r6 > target_moho_low &
- .and. r7 > target_moho_low .and. r8 > target_moho_low) then
- ispec2D_moho_bot = ispec2D_moho_bot + 1
- ix=map_ix(ispec_superbrick)
- iy=map_iy(ispec_superbrick)
- if (ix == 0 .or. iy == 0) call exit_mpi(myrank, 'Check (ix,iy) on the Moho bot is 0')
- ix_top = (ix_elem - 1) + ix
- iy_top = (iy_elem - 1) + iy
- ispec2D_moho_bot_map = (ix_top - 1) * nex_eta_moho + iy_top
-! if (myrank == 0) write(*,'(10i6)') ix_elem, iy_elem, ispec_superbrick, ix, iy, ix_top, iy_top, ispec2D_moho_bot_map
- ibelm_moho_bot(ispec2D_moho_bot_map) = ispec
- endif
- endif
-
-
-end subroutine get_jacobian_discontinuities
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_model.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_model.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,436 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine get_model(myrank,iregion_code,ispec,nspec,idoubling, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- rhostore,dvpstore,nspec_ani, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- nspec_stacey,rho_vp,rho_vs, &
- xstore,ystore,zstore, &
- rmin,rmax,RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220, &
- R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- tau_s,tau_e_store,Qmu_store,T_c_source,vx,vy,vz,vnspec, &
- ABSORBING_CONDITIONS,elem_in_crust,elem_in_mantle)
-
- use meshfem3D_models_par
-
- implicit none
-
- integer myrank,iregion_code,ispec,nspec,idoubling
-
- 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)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) dvpstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer nspec_ani
- 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
-
- integer nspec_stacey
- real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey),rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
-
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
-
- double precision rmin,rmax,RCMB,RICB,R670,RMOHO, &
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
-
- ! attenuation values
- integer vx,vy,vz,vnspec
- double precision, dimension(N_SLS) :: tau_s
- 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 ABSORBING_CONDITIONS
- logical elem_in_crust,elem_in_mantle
-
- ! local parameters
- double precision xmesh,ymesh,zmesh
- ! 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
- double precision, dimension(N_SLS) :: tau_e
-
- ! local parameters
- double precision rho,dvp
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision Qkappa,Qmu
- double precision r,r_prem,moho
- integer i,j,k
-
- ! loops over all gll points for this spectral element
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- ! initializes values
- rho = 0.d0
- vpv = 0.d0
- vph = 0.d0
- vsv = 0.d0
- vsh = 0.d0
- eta_aniso = 0.d0
- c11 = 0.d0
- c12 = 0.d0
- c13 = 0.d0
- c14 = 0.d0
- c15 = 0.d0
- c16 = 0.d0
- c22 = 0.d0
- c23 = 0.d0
- c24 = 0.d0
- c25 = 0.d0
- c26 = 0.d0
- c33 = 0.d0
- c34 = 0.d0
- c35 = 0.d0
- c36 = 0.d0
- c44 = 0.d0
- c45 = 0.d0
- c46 = 0.d0
- c55 = 0.d0
- c56 = 0.d0
- c66 = 0.d0
- Qmu = 0.d0
- Qkappa = 0.d0 ! not used, not stored so far...
- tau_e(:) = 0.d0
- dvp = 0.d0
-
- ! sets xyz coordinates of GLL point
- xmesh = xstore(i,j,k,ispec)
- ymesh = ystore(i,j,k,ispec)
- zmesh = zstore(i,j,k,ispec)
-
- ! exact point location radius
- r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*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
- ! checks r_prem,rmin/rmax and assigned idoubling
- call get_model_check_idoubling(r_prem,xmesh,ymesh,zmesh,rmin,rmax,idoubling, &
- RICB,RCMB,RTOPDDOUBLEPRIME, &
- R220,R670,myrank)
-
- ! gets reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
- call meshfem3D_models_get1D_val(myrank,iregion_code,idoubling, &
- r_prem,rho,vpv,vph,vsv,vsh,eta_aniso, &
- Qkappa,Qmu,RICB,RCMB, &
- RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
- RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- ! gets the 3-D model parameters for the mantle
- call meshfem3D_models_get3Dmntl_val(iregion_code,r_prem,rho,dvp,&
- vpv,vph,vsv,vsh,eta_aniso, &
- RCMB,R670,RMOHO, &
- xmesh,ymesh,zmesh,r, &
- c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
- c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
-
- ! gets the 3-D crustal model
- if( CRUSTAL ) then
- if( .not. elem_in_mantle) &
- call meshfem3D_models_get3Dcrust_val(iregion_code,xmesh,ymesh,zmesh,r, &
- vpv,vph,vsv,vsh,rho,eta_aniso,dvp, &
- c11,c12,c13,c14,c15,c16,c22,c23,c24,c25, &
- c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66, &
- elem_in_crust,moho)
- endif
-
- ! overwrites with tomographic model values (from iteration step) here, given at all GLL points
- call meshfem3D_models_impose_val(vpv,vph,vsv,vsh,rho,dvp,eta_aniso,&
- myrank,iregion_code,ispec,i,j,k)
-
- ! checks vpv: if close to zero then there is probably an error
- if( vpv < TINYVAL ) then
- print*,'error vpv: ',vpv,vph,vsv,vsh,rho
- print*,'radius:',r*R_EARTH_KM
- call exit_mpi(myrank,'error get_model values')
- endif
-
- !> Hejun
- ! New Attenuation assignment
- ! Define 3D and 1D Attenuation after moho stretch
- ! and before TOPOGRAPHY/ELLIPCITY
- !
- !note: only Qmu attenuation considered, Qkappa attenuation not used so far...
- if( ATTENUATION ) &
- call meshfem3D_models_getatten_val(idoubling,xmesh,ymesh,zmesh,r_prem, &
- tau_e,tau_s,T_c_source, &
- moho,Qmu,Qkappa,elem_in_crust) ! R80
-
-! define elastic parameters in the model
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
-
- rhostore(i,j,k,ispec) = sngl(rho)
- kappavstore(i,j,k,ispec) = sngl(rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0))
- kappahstore(i,j,k,ispec) = sngl(rho*(vph*vph - 4.d0*vsh*vsh/3.d0))
- muvstore(i,j,k,ispec) = sngl(rho*vsv*vsv)
- muhstore(i,j,k,ispec) = sngl(rho*vsh*vsh)
- eta_anisostore(i,j,k,ispec) = sngl(eta_aniso)
-
- if (HETEROGEN_3D_MANTLE) then
- dvpstore(i,j,k,ispec) = sngl(dvp)
- 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
- !double precision
-
- rhostore(i,j,k,ispec) = rho
- kappavstore(i,j,k,ispec) = rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0)
- kappahstore(i,j,k,ispec) = rho*(vph*vph - 4.d0*vsh*vsh/3.d0)
- muvstore(i,j,k,ispec) = rho*vsv*vsv
- muhstore(i,j,k,ispec) = rho*vsh*vsh
- eta_anisostore(i,j,k,ispec) = eta_aniso
-
- if (HETEROGEN_3D_MANTLE) then
- dvpstore(i,j,k,ispec) = dvp
- 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 !CUSTOM_REAL
-
- !> Hejun
- ! No matter 1D or 3D attenuation, we save all gll point values
- if(ATTENUATION) 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
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine get_model_check_idoubling(r_prem,x,y,z,rmin,rmax,idoubling, &
- RICB,RCMB,RTOPDDOUBLEPRIME, &
- R220,R670,myrank)
-
- use meshfem3D_models_par
-
- implicit none
-
- !include "constants.h"
-
- integer idoubling,myrank
-
- double precision r_prem,rmin,rmax,x,y,z
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R670,R220
- double precision r_m,r,theta,phi
-
- ! compute real physical radius in meters
- r_m = r_prem * R_EARTH
-
- ! checks layers
- if( abs(rmax - rmin ) < TINYVAL ) then
- ! there's probably an error
- print*,'error layer radius min/max:',rmin,rmax
- print*,' point radius: ',r_prem
- call exit_mpi(myrank,'error in get_model_check_idoubling() layer radius')
- endif
-
-
- ! 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_m >= 0.d0 .and. r_m < 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) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
- print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
- print*,' idoubling/IFLAG: ',idoubling,IFLAG_INNER_CORE_NORMAL,'-to-',IFLAG_IN_FICTITIOUS_CUBE
- call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for inner core point')
- endif
- !
- !--- outer core
- !
- else if(r_m > RICB .and. r_m < RCMB) then
- if(idoubling /= IFLAG_OUTER_CORE_NORMAL) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
- print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
- print*,' idoubling/IFLAG: ',idoubling,IFLAG_OUTER_CORE_NORMAL
- call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for outer core point')
- endif
- !
- !--- D" at the base of the mantle
- !
- else if(r_m > RCMB .and. r_m < RTOPDDOUBLEPRIME) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
- print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
- print*,' dprime radius/RCMB/RTOPDDOUBLEPRIME:',r_m, RCMB,RTOPDDOUBLEPRIME
- print*,' idoubling/IFLAG: ',idoubling,IFLAG_MANTLE_NORMAL
- call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for D" point')
- endif
- !
- !--- mantle: from top of D" to d670
- !
- else if(r_m > RTOPDDOUBLEPRIME .and. r_m < R670) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
- print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
- print*,' idoubling/IFLAG: ',idoubling,IFLAG_MANTLE_NORMAL
- call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for top D" -> d670 point')
- endif
-
- !
- !--- mantle: from d670 to d220
- !
- else if(r_m > R670 .and. r_m < R220) then
- if(idoubling /= IFLAG_670_220) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
- print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
- print*,' idoubling/IFLAG: ',idoubling,IFLAG_670_220
- call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for d670 -> d220 point')
- endif
-
- !
- !--- mantle and crust: from d220 to MOHO and then to surface
- !
- else if(r_m > R220) then
- if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
- print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
- print*,' idoubling/IFLAG: ',idoubling,IFLAG_220_80,IFLAG_80_MOHO,IFLAG_CRUST
- call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for d220 -> Moho -> surface point')
- endif
-
- endif
-
- end subroutine get_model_check_idoubling
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_model_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_model_parameters.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_model_parameters.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,668 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine get_model_parameters(MODEL,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
- CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO, &
- ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY, &
- OCEANS,TOPOGRAPHY, &
- ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R120,R220,R400,R600,R670,R771, &
- RTOPDDOUBLEPRIME,RCMB,RICB,RMOHO_FICTITIOUS_IN_MESHER, &
- R80_FICTITIOUS_IN_MESHER,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS)
-
-
- implicit none
-
- include "constants.h"
-
- character(len=150) MODEL
-
- integer REFERENCE_1D_MODEL,THREE_D_MODEL
-
- logical ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
- CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO,&
- ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY
-
- logical OCEANS,TOPOGRAPHY
-
- double precision ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
-
- double precision RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS
-
- ! turns on/off corresponding 1-D/3-D model flags
- call get_model_parameters_flags(MODEL,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
- CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO, &
- ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY, &
- OCEANS,TOPOGRAPHY)
-
- ! sets radius for each discontinuity and ocean density values
- call get_model_parameters_radii(REFERENCE_1D_MODEL,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771, &
- RTOPDDOUBLEPRIME,RCMB,RICB, &
- RMOHO_FICTITIOUS_IN_MESHER, &
- R80_FICTITIOUS_IN_MESHER, &
- RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
- HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL)
-
-
- end subroutine get_model_parameters
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine get_model_parameters_flags(MODEL,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
- CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO, &
- ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY, &
- OCEANS,TOPOGRAPHY)
-
-
- implicit none
-
- include "constants.h"
-
- character(len=150) MODEL
-
- integer REFERENCE_1D_MODEL,THREE_D_MODEL
-
- logical ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
- CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO,&
- ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY
- logical OCEANS,TOPOGRAPHY
-
- ! local parameters
- character(len=4) ending
- character(len=8) ending_1Dcrust
-
- character(len=150) MODEL_ROOT
- logical :: impose_1Dcrust
-
- ! defaults:
- !
- ! 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.
- !
-
- ! extract ending of model name
- ending = ' '
- if( len_trim(MODEL) > 4 ) ending = MODEL(len_trim(MODEL)-3:len_trim(MODEL))
-
- ! determines if the anisotropic inner core option should be turned on
- if( ending == '_AIC' ) then
- ANISOTROPIC_INNER_CORE = .true.
- ! in case it has an ending for the inner core, remove it from the name
- MODEL_ROOT = MODEL(1: len_trim(MODEL)-4)
- else
- ANISOTROPIC_INNER_CORE = .false.
- ! sets root name of model to original one
- MODEL_ROOT = MODEL
- endif
-
- ! checks with '_1Dcrust' option
- impose_1Dcrust = .false.
- ending_1Dcrust = ' '
- if( len_trim(MODEL_ROOT) > 8 ) &
- ending_1Dcrust = MODEL_ROOT(len_trim(MODEL_ROOT)-7:len_trim(MODEL_ROOT))
- if( ending_1Dcrust == '_1Dcrust' ) then
- impose_1Dcrust = .true.
- ! in case it has an ending for the inner core, remove it from the name
- MODEL_ROOT = MODEL_ROOT(1: len_trim(MODEL)-8)
- endif
-
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
-
- ! uses PREM as the 1D reference model by default
- ! uses no mantle heterogeneities by default
- ! uses no 3D model by default
- ANISOTROPIC_3D_MANTLE = .false.
- ATTENUATION_3D = .false.
- CASE_3D = .false.
- CRUSTAL = .false.
- HETEROGEN_3D_MANTLE = .false.
- HONOR_1D_SPHERICAL_MOHO = .false.
- ISOTROPIC_3D_MANTLE = .false.
- ONE_CRUST = .false.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
- THREE_D_MODEL = 0
- TRANSVERSE_ISOTROPY = .false.
-
- ! model specifics
-
- ! 1-D models
- if(MODEL_ROOT == '1D_isotropic_prem') then
- HONOR_1D_SPHERICAL_MOHO = .true.
-
- else if(MODEL_ROOT == '1D_transversely_isotropic_prem') then
- HONOR_1D_SPHERICAL_MOHO = .true.
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == '1D_iasp91' .or. MODEL_ROOT == '1D_1066a' .or. &
- MODEL_ROOT == '1D_ak135' .or. MODEL_ROOT == '1D_jp3d' .or. &
- MODEL_ROOT == '1D_sea99') then
- HONOR_1D_SPHERICAL_MOHO = .true.
- if(MODEL_ROOT == '1D_iasp91') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
- else if(MODEL_ROOT == '1D_1066a') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
- else if(MODEL_ROOT == '1D_ak135') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
- else if(MODEL_ROOT == '1D_jp3d') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
- else if(MODEL_ROOT == '1D_sea99') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
- else
- stop 'reference 1D Earth model unknown'
- endif
-
- else if(MODEL_ROOT == '1D_ref') then
- HONOR_1D_SPHERICAL_MOHO = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == '1D_ref_iso') then
- HONOR_1D_SPHERICAL_MOHO = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
-
- else if(MODEL_ROOT == '1D_isotropic_prem_onecrust') then
- HONOR_1D_SPHERICAL_MOHO = .true.
- ONE_CRUST = .true.
-
- else if(MODEL_ROOT == '1D_transversely_isotropic_prem_onecrust') then
- TRANSVERSE_ISOTROPY = .true.
- HONOR_1D_SPHERICAL_MOHO = .true.
- ONE_CRUST = .true.
-
- else if(MODEL_ROOT == '1D_iasp91_onecrust' .or. MODEL_ROOT == '1D_1066a_onecrust' &
- .or. MODEL_ROOT == '1D_ak135_onecrust') then
- HONOR_1D_SPHERICAL_MOHO = .true.
- ONE_CRUST = .true.
- if(MODEL_ROOT == '1D_iasp91_onecrust') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
- else if(MODEL_ROOT == '1D_1066a_onecrust') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
- else if(MODEL_ROOT == '1D_ak135_onecrust') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
- else
- stop 'reference 1D Earth model unknown'
- endif
-
- ! 3-D models
- else if(MODEL_ROOT == 'transversely_isotropic_prem_plus_3D_crust_2.0') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ONE_CRUST = .true.
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == 's20rts') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- THREE_D_MODEL = THREE_D_MODEL_S20RTS
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == 's40rts') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- THREE_D_MODEL = THREE_D_MODEL_S40RTS
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == 'sea99_jp3d1994') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
- THREE_D_MODEL = THREE_D_MODEL_SEA99_JP3D
-
- else if(MODEL_ROOT == 'sea99') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
- THREE_D_MODEL = THREE_D_MODEL_SEA99
-
- else if(MODEL_ROOT == 'jp3d1994') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
- THREE_D_MODEL = THREE_D_MODEL_JP3D
-
- else if(MODEL_ROOT == 's362ani') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
- THREE_D_MODEL = THREE_D_MODEL_S362ANI
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == 's362iso') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
- THREE_D_MODEL = THREE_D_MODEL_S362ANI
-
- else if(MODEL_ROOT == 's362wmani') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
- THREE_D_MODEL = THREE_D_MODEL_S362WMANI
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == 's362ani_prem') then
- CASE_3D = .true.
- CRUSTAL = .true.
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- THREE_D_MODEL = THREE_D_MODEL_S362ANI_PREM
-
- else if(MODEL_ROOT == 's362ani_3DQ') then
- ATTENUATION_3D = .true.
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
- THREE_D_MODEL = THREE_D_MODEL_S362ANI
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == 's362iso_3DQ') then
- ATTENUATION_3D = .true.
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
- THREE_D_MODEL = THREE_D_MODEL_S362ANI
-
- else if(MODEL_ROOT == 's29ea') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
- THREE_D_MODEL = THREE_D_MODEL_S29EA
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == '3D_attenuation') then
- ATTENUATION_3D = .true.
- CASE_3D = .true.
- ONE_CRUST = .true.
-
- else if(MODEL_ROOT == '3D_anisotropic') then
- ANISOTROPIC_3D_MANTLE = .true.
- CASE_3D = .true.
- ONE_CRUST = .true.
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == 'heterogen') then
- CASE_3D = .true.
- CRUSTAL = .true.
- HETEROGEN_3D_MANTLE = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
- THREE_D_MODEL = THREE_D_MODEL_S362ANI
- TRANSVERSE_ISOTROPY = .true.
-
- else if(MODEL_ROOT == 'PPM') then
- ! overimposed based on isotropic-prem
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- THREE_D_MODEL = THREE_D_MODEL_PPM
- TRANSVERSE_ISOTROPY = .true. ! to use transverse-isotropic prem
-
- else if(MODEL_ROOT == 'GLL') then
- ! model will be given on local basis, at all GLL points,
- ! as from meshfem3d output from routine save_arrays_solver()
- ! based on model s29ea
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
- THREE_D_MODEL = THREE_D_MODEL_GLL
- TRANSVERSE_ISOTROPY = .true.
- ! note: after call to this routines read_compute_parameters() we will set
- ! mgll_v%model_gll flag and reset
- ! THREE_D_MODEL = THREE_D_MODEL_S29EA
- ! (not done here because we will use mgll_v%model_gll flag to identify this
- ! model, based upon the s29ea model, but putting mgll_v as parameter to this
- ! routine involves too many changes. )
-
- else if(MODEL == 'gapp2') then
- CASE_3D = .true.
- CRUSTAL = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ONE_CRUST = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
- THREE_D_MODEL = THREE_D_MODEL_GAPP2
- TRANSVERSE_ISOTROPY = .true.
-
- else
- print*
- print*,'error model: ',trim(MODEL)
- stop 'model not implemented yet, edit get_model_parameters.f90 and recompile'
- endif
-
- ! suppress the crustal layers
- if( SUPPRESS_CRUSTAL_MESH ) then
- CRUSTAL = .false.
- OCEANS = .false.
- ONE_CRUST = .false.
- TOPOGRAPHY = .false.
- endif
-
- ! additional option for 3D mantle models:
- ! this takes crust from reference 1D model rather than a 3D crust;
- if( impose_1Dcrust ) then
- ! no 3D crust
- CRUSTAL = .false.
- ! no crustal moho stretching
- CASE_3D = .false.
- ! mesh honors the 1D moho depth
- HONOR_1D_SPHERICAL_MOHO = .true.
- ! 2 element layers in top crust region rather than just one
- ONE_CRUST = .false.
- endif
-
- ! checks flag consistency for crust
- if( HONOR_1D_SPHERICAL_MOHO .and. CRUSTAL ) &
- stop 'honor 1D spherical moho excludes having 3D crustal structure'
-
- ! checks 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'
-
-
- end subroutine get_model_parameters_flags
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine get_model_parameters_radii(REFERENCE_1D_MODEL,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771, &
- RTOPDDOUBLEPRIME,RCMB,RICB, &
- RMOHO_FICTITIOUS_IN_MESHER, &
- R80_FICTITIOUS_IN_MESHER, &
- RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
- HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL)
-
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
- integer REFERENCE_1D_MODEL
-
- double precision ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
-
- double precision RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS
-
- logical HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL
-
-! 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)
-
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
- ! default: PREM
- ROCEAN = 6368000.d0
- RMIDDLE_CRUST = 6356000.d0
- RMOHO = 6346600.d0
- R80 = 6291000.d0
- R120 = -1.d0 ! by default there is no d120 discontinuity, except in IASP91, therefore set to fictitious value
- R220 = 6151000.d0
- R400 = 5971000.d0
- R600 = 5771000.d0
- R670 = 5701000.d0
- R771 = 5600000.d0
- RTOPDDOUBLEPRIME = 3630000.d0
- RCMB = 3480000.d0
- RICB = 1221000.d0
-
- ! density ocean
- RHO_OCEANS = 1020.0 / RHOAV ! value common to all models
- ! densities fluid outer core
- RHO_TOP_OC = 9903.4384 / RHOAV
- RHO_BOTTOM_OC = 12166.5885 / RHOAV
-
- ! differing 1-D model radii
- 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_1DREF) 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
-
- 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
- ! 1D models: all honor their spherical moho
- RMOHO_FICTITIOUS_IN_MESHER = RMOHO
- R80_FICTITIOUS_IN_MESHER = R80
- else
- ! 3D models do not honor PREM moho but a fictitious moho at 40km depth:
- ! either to make simulation cheaper or to have a 3D crustal structure
- RMOHO_FICTITIOUS_IN_MESHER = (R80 + R_EARTH) / 2.0d0
- R80_FICTITIOUS_IN_MESHER = R80
- if( CRUSTAL .and. CASE_3D ) then
- !> Hejun
- ! mesh will honor 3D crustal moho topography
- ! moves MOHO up 5km to honor moho topography deeper than 35 km
- ! moves R80 down to 120km depth in order to have less squeezing for elements below moho
- RMOHO_FICTITIOUS_IN_MESHER = RMOHO_FICTITIOUS_IN_MESHER + RMOHO_STRETCH_ADJUSTEMENT
- R80_FICTITIOUS_IN_MESHER = R80_FICTITIOUS_IN_MESHER + R80_STRETCH_ADJUSTEMENT
- endif
- endif
-
- end subroutine get_model_parameters_radii
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/get_shape2D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_shape2D.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_shape2D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/get_shape3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_shape3D.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_shape3D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/get_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_value_parameters.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_value_parameters.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,101 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
- subroutine 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
-
-!--------------------
-
-! 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
-
-!--------------------
-
-!
-! unused routines:
-!
-
-! 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
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/gll_library.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/gll_library.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/gll_library.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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/hex_nodes.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/hex_nodes.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/hex_nodes.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/initialize_simulation.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/initialize_simulation.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,522 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
- subroutine initialize_simulation(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,NEX_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,SIMULATION_TYPE, &
- DT,ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670,R771,&
- RTOPDDOUBLEPRIME,RCMB,RICB, &
- RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- HDUR_MOVIE,MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST, &
- MOVIE_NORTH,MOVIE_SOUTH,MOVIE_SURFACE,MOVIE_VOLUME, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
- LOCAL_PATH,OUTPUT_FILES, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top, &
- this_region_has_a_doubling,rmins,rmaxs, &
- TOPOGRAPHY,HONOR_1D_SPHERICAL_MOHO,ONE_CRUST, &
- nspl,rspl,espl,espl2,ibathy_topo, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- xigll,yigll,zigll,wxgll,wygll,wzgll,wgll_cube, &
- hprime_xx,hprime_yy,hprime_zz,hprime_xxT, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- rec_filename,STATIONS,nrec,NOISE_TOMOGRAPHY)
-
- implicit none
-
- include 'mpif.h'
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- ! 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, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
-
- logical MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT,&
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE
-
- character(len=150) LOCAL_PATH,OUTPUT_FILES
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ratio_sampling_array,ner
- 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
-
-
- ! mesh model parameters
- logical TOPOGRAPHY,HONOR_1D_SPHERICAL_MOHO,ONE_CRUST
- !logical COMPUTE_AND_STORE_STRAIN
-
- ! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
- ! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
-
- ! 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,NGLLX) :: hprime_xxT,hprimewgll_xxT
- 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
-
- character(len=150) rec_filename,STATIONS
- integer nrec
-
- ! local parameters
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC_computed,NGLOB_computed, &
- NSPEC2D_XI,NSPEC2D_ETA,NSPEC1D_RADIAL
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
- integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
- integer :: ratio_divide_central_cube
- integer :: sizeprocs
- integer :: ier,i,j,ios
- integer :: NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,NPROC_XI,NPROC_ETA
- double precision :: RMOHO_FICTITIOUS_IN_MESHER,R120,R_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,&
- CENTER_LATITUDE_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,ANGULAR_WIDTH_XI_IN_DEGREES,&
- GAMMA_ROTATION_AZIMUTH
- integer :: REFERENCE_1D_MODEL,THREE_D_MODEL
- logical :: TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS, &
- ATTENUATION,ATTENUATION_3D,ROTATION,ELLIPTICITY,GRAVITY,CASE_3D,ISOTROPIC_3D_MANTLE, &
- HETEROGEN_3D_MANTLE,CRUSTAL,INFLATE_CENTRAL_CUBE
- character(len=150) :: MODEL,dummystring
- integer, external :: err_occurred
-
- ! 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
- call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
-
- 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,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC_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.,NOISE_TOMOGRAPHY)
-
- if(err_occurred() /= 0) then
- call exit_MPI(myrank,'an error occurred while reading the parameter file')
- endif
-
- endif
-
- ! distributes parameters from master to all processes
- ! note: uses NSPEC_computed,NGLOB_computed as arguments
- call broadcast_compute_parameters(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- RMOHO_FICTITIOUS_IN_MESHER, &
- MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
- LOCAL_PATH,MODEL, &
- 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, &
- ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
- HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
- ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY)
-
- ! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
- ! open main output file, only written to by process 0
- if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
- open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_solver.txt',status='unknown',action='write')
-
- if(myrank == 0) then
-
- write(IMAIN,*)
- write(IMAIN,*) '******************************'
- write(IMAIN,*) '**** Specfem3D MPI Solver ****'
- write(IMAIN,*) '******************************'
- write(IMAIN,*)
- write(IMAIN,*)
-
- if(FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field'
-
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
- write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
- write(IMAIN,*)
-
- write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
- write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
- write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
- write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
- write(IMAIN,*) 'There are ',NCHUNKS,' chunks'
- write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in all the chunks'
-
- write(IMAIN,*)
- write(IMAIN,*) 'NDIM = ',NDIM
- write(IMAIN,*)
- write(IMAIN,*) 'NGLLX = ',NGLLX
- write(IMAIN,*) 'NGLLY = ',NGLLY
- write(IMAIN,*) 'NGLLZ = ',NGLLZ
- write(IMAIN,*)
-
- ! write information about precision used for floating-point operations
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IMAIN,*) 'using single precision for the calculations'
- else
- write(IMAIN,*) 'using double precision for the calculations'
- endif
- write(IMAIN,*)
- write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ', &
- tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
- write(IMAIN,*)
-
- write(IMAIN,*) 'model:'
-
- if(ISOTROPIC_3D_MANTLE) then
- write(IMAIN,*) ' incorporates 3-D lateral variations'
- else
- write(IMAIN,*) ' no 3-D lateral variations'
- endif
- if(HETEROGEN_3D_MANTLE) then
- write(IMAIN,*) ' incorporates heterogeneities in the mantle'
- else
- write(IMAIN,*) ' no heterogeneities in the mantle'
- endif
- if(CRUSTAL) then
- write(IMAIN,*) ' incorporates crustal variations'
- else
- write(IMAIN,*) ' no crustal variations'
- endif
- if(ONE_CRUST) then
- write(IMAIN,*) ' uses one layer only in PREM crust'
- else
- write(IMAIN,*) ' uses unmodified 1D crustal model with two layers'
- endif
- if(TRANSVERSE_ISOTROPY) then
- write(IMAIN,*) ' incorporates transverse isotropy'
- else
- write(IMAIN,*) ' no transverse isotropy'
- endif
- if(ANISOTROPIC_INNER_CORE_VAL) then
- write(IMAIN,*) ' incorporates anisotropic inner core'
- else
- write(IMAIN,*) ' no inner-core anisotropy'
- endif
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- write(IMAIN,*) ' incorporates anisotropic mantle'
- else
- write(IMAIN,*) ' no general mantle anisotropy'
- endif
-
- write(IMAIN,*)
- 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(initialization specfem)')
-
- ! check that the code has been compiled with the right values
- if (NSPEC_computed(IREGION_CRUST_MANTLE) /= NSPEC_CRUST_MANTLE) then
- write(IMAIN,*) 'NSPEC_CRUST_MANTLE:',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_OUTER_CORE:',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_INNER_CORE:',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,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,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,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,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,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,ELLIPTICITY_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 10')
- endif
- if (OCEANS .NEQV. OCEANS_VAL) then
- write(IMAIN,*) 'OCEANS:',OCEANS,OCEANS_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 10')
- endif
- if (NPROCTOT /= NPROCTOT_VAL) then
- write(IMAIN,*) 'NPROCTOT:',NPROCTOT,NPROCTOT_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 11')
- endif
- if (NPROC_XI /= NPROC_XI_VAL) then
- write(IMAIN,*) 'NPROC_XI:',NPROC_XI,NPROC_XI_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 11')
- endif
- if (NPROC_ETA /= NPROC_ETA_VAL) then
- write(IMAIN,*) 'NPROC_ETA:',NPROC_ETA,NPROC_ETA_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,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,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,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,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,ANISOTROPIC_INNER_CORE_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 16')
- endif
-
- ! check simulation pararmeters
- if (SIMULATION_TYPE /= 1 .and. SIMULATION_TYPE /= 2 .and. SIMULATION_TYPE /= 3) &
- call exit_MPI(myrank, 'SIMULATION_TYPE can only be 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((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then
- if ( ATTENUATION_VAL) then
- ! checks mimic flag:
- ! attenuation for adjoint simulations must have USE_ATTENUATION_MIMIC set by xcreate_header_file
- if( USE_ATTENUATION_MIMIC .eqv. .false. ) &
- call exit_MPI(myrank,'error in compiled attenuation parameters, please recompile solver 17b')
-
- ! user output
- if( myrank == 0 ) write(IMAIN,*) 'incorporates ATTENUATION for time-reversed simulation'
- endif
-
- ! checks adjoint array dimensions
- if(NSPEC_CRUST_MANTLE_ADJOINT /= NSPEC_CRUST_MANTLE &
- .or. NSPEC_OUTER_CORE_ADJOINT /= NSPEC_OUTER_CORE &
- .or. NSPEC_INNER_CORE_ADJOINT /= NSPEC_INNER_CORE &
- .or. NGLOB_CRUST_MANTLE_ADJOINT /= NGLOB_CRUST_MANTLE &
- .or. NGLOB_OUTER_CORE_ADJOINT /= NGLOB_OUTER_CORE &
- .or. NGLOB_INNER_CORE_ADJOINT /= NGLOB_INNER_CORE) &
- call exit_MPI(myrank, 'improper dimensions of adjoint arrays, please recompile solver 18')
- endif
-
- ! checks 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')
- endif
-
- ! checks strain storage
- if (ATTENUATION_VAL .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD &
- .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
- if( COMPUTE_AND_STORE_STRAIN .neqv. .true. ) &
- call exit_MPI(myrank, 'error in compiled compute_and_store_strain parameter, please recompile solver 19')
- else
- if( COMPUTE_AND_STORE_STRAIN .neqv. .false. ) &
- call exit_MPI(myrank, 'error in compiled compute_and_store_strain parameter, please recompile solver 20')
- endif
-
- if (SIMULATION_TYPE == 3 .and. (ANISOTROPIC_3D_MANTLE_VAL .or. ANISOTROPIC_INNER_CORE_VAL)) &
- call exit_MPI(myrank, 'anisotropic model is not implemented for kernel simulations yet')
-
- ! checks model for transverse isotropic kernel computation
- if( SAVE_TRANSVERSE_KL ) then
- if( ANISOTROPIC_3D_MANTLE_VAL ) then
- call exit_mpi(myrank,'error SAVE_TRANSVERSE_KL: Earth model not supported yet')
- endif
- if( SIMULATION_TYPE == 3 ) then
- if( .not. ANISOTROPIC_KL ) then
- call exit_mpi(myrank,'error SAVE_TRANSVERSE_KL: needs anisotropic kernel calculations')
- endif
- endif
- endif
-
- ! make ellipticity
- if(ELLIPTICITY_VAL) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
-
- ! read topography and bathymetry file
- if(myrank == 0 .and. (TOPOGRAPHY .or. OCEANS_VAL)) 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)
-
- ! 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)
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
-
- ! check that optimized routines from Deville et al. (2002) can be used
- if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
- stop 'Deville et al. (2002) routines can only be used if NGLLX = NGLLY = NGLLZ = 5'
-
- ! define transpose of derivation matrix
- do j = 1,NGLLY
- do i = 1,NGLLX
- hprime_xxT(j,i) = hprime_xx(i,j)
- hprimewgll_xxT(j,i) = hprimewgll_xx(i,j)
- enddo
- enddo
- endif
-
- ! counts receiver stations
- if (SIMULATION_TYPE == 1) then
- rec_filename = 'DATA/STATIONS'
- else
- rec_filename = 'DATA/STATIONS_ADJOINT'
- endif
- 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(nrec < 1) call exit_MPI(myrank,trim(STATIONS)//': need at least one receiver')
-
-
- end subroutine initialize_simulation
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/intgrl.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/intgrl.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/intgrl.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,192 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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
- double precision, parameter :: third = 1.0d0/3.0d0
- double precision, parameter :: fifth = 1.0d0/5.0d0
- double precision, parameter :: sixth = 1.0d0/6.0d0
-
- double precision rji,yprime(640)
- double precision s1l,s2l,s3l
-
- integer i,j,n,kdis(28)
- integer ndis,nir1
-
-
-
- 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)
- s1l = s1(j)
- s2l = s2(j)
- s3l = s3(j)
- sum = sum + r(j)*r(j)*rji*(f(j) &
- + rji*(0.5d0*s1l + rji*(third*s2l + rji*0.25d0*s3l))) &
- + 2.0d0*r(j)*rji*rji*(0.5d0*f(j) + rji*(third*s1l + rji*(0.25d0*s2l + rji*fifth*s3l))) &
- + rji*rji*rji*(third*f(j) + rji*(0.25d0*s1l + rji*(fifth*s2l + rji*sixth*s3l)))
- 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/lagrange_poly.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/lagrange_poly.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/lagrange_poly.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/lgndr.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/lgndr.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/lgndr.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/locate_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/locate_receivers.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/locate_receivers.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,735 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!----
-!---- 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,stbur,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,stbur_found,epidist_found
- character(len=150) STATIONS
-
- integer, allocatable, dimension(:,:) :: ispec_selected_rec_all
- double precision, dimension(nrec) :: stlat,stlon,stele,stbur
- double precision, allocatable, dimension(:,:) :: xi_receiver_all,eta_receiver_all,gamma_receiver_all
-
- character(len=150) OUTPUT_FILES
- character(len=2) bic
-
-! **************
-
-! 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(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',iostat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error opening STATIONS file')
-
- ! loop on all the stations to read station information
- do irec = 1,nrec
- read(1,*,iostat=ier) station_name(irec),network_name(irec),stlat(irec),stlon(irec),stele(irec),stbur(irec)
- if( ier /= 0 ) then
- write(IMAIN,*) 'error reading in station ',irec
- call exit_MPI(myrank,'error reading in station in STATIONS file')
- endif
- enddo
- ! close receiver file
- close(1)
-
- ! if receivers can not be buried, sets depth to zero
- if( .not. RECEIVERS_CAN_BE_BURIED ) stbur(:) = 0.d0
-
- 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)
- if(ASSUME_PERFECT_SPHERE) then
- theta = PI/2.0d0 - stlat(irec)*PI/180.0d0
- else
- theta = PI/2.0d0 - atan(0.99329534d0*dtan(stlat(irec)*PI/180.0d0))
- endif
-
- 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)
-
- if (myrank == 0) write(IOVTK,*) sngl(x_target(irec)), sngl(y_target(irec)), sngl(z_target(irec))
-
-! 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')
- call band_instrument_code(DT,bic)
-
- ! 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
- 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),bic(1:2)//'N',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),bic(1:2)//'E',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),bic(1:2)//'Z',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
- 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),bic(1:2)//'N',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),bic(1:2)//'E',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),bic(1:2)//'Z',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)
- stbur_found(nrec_found) = stbur(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)
- stbur(1:nrec) = stbur_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)
-
- ! write out a filtered station list
- if( NCHUNKS /= 6 ) then
- open(unit=27,file=trim(OUTPUT_FILES)//'/STATIONS_FILTERED',status='unknown')
- ! loop on all the stations to read station information
- do irec = 1,nrec
- write(27,'(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1)') trim(station_name(irec)),&
- trim(network_name(irec)),sngl(stlat(irec)),&
- sngl(stlon(irec)),sngl(stele(irec)),sngl(stbur(irec))
- enddo
- ! close receiver file
- close(27)
- endif
-
-
-
-! 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(stbur,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(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/locate_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/locate_sources.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/locate_sources.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,926 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!----
-!---- 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,tshift_cmt,min_tshift_cmt_original,yr,jda,ho,mi,theta_source,phi_source, &
- NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- islice_selected_source,ispec_selected_source, &
- xi_source,eta_source,gamma_source, nu_source, &
- rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION, &
- LOCAL_PATH,SIMULATION_TYPE)
-
- implicit none
-
-! 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
-
- integer nspec,nglob,myrank
-
- 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)
-
- ! moment-tensor source parameters
- double precision sec,min_tshift_cmt_original
- double precision tshift_cmt(NSOURCES)
- integer yr,jda,ho,mi
- double precision, dimension(NSOURCES) :: theta_source,phi_source
- double precision hdur(NSOURCES)
- double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
-
- ! source locations
- integer ispec_selected_source(NSOURCES)
- integer islice_selected_source(NSOURCES)
-
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision nu_source(NDIM,NDIM,NSOURCES)
-
- ! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
- ! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
- character(len=150) :: LOCAL_PATH
- integer :: SIMULATION_TYPE
-
-! local parameters
- integer isource
- integer iprocloop
- integer i,j,k,ispec,iglob
- integer ier
-
- double precision t0, hdur_gaussian(NSOURCES)
-
- double precision ell
- double precision elevation
- double precision r0,dcost,p20
- double precision theta,phi
- 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
-
- ! timer MPI
- double precision time_start,tCPU
-
- integer isources_already_done,isource_in_this_subset
- 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, 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
- integer :: 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
- double precision, external :: comp_source_time_function_rickr
-
-! 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)
- integer imin,imax,jmin,jmax,kmin,kmax
- double precision :: f0,t0_ricker
- double precision t_cmt_used(NSOURCES)
-
-! mask source region (mask values are between 0 and 1, with 0 around sources)
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable :: mask_source
-
-! **************
-
-! make sure we clean the future final array
- ispec_selected_source(:) = 0
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! read all the sources
- if(myrank == 0) call get_cmt(yr,jda,ho,mi,sec,tshift_cmt,hdur,lat,long,depth,moment_tensor, &
- DT,NSOURCES,min_tshift_cmt_original)
-
-! 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(tshift_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)
- call MPI_BCAST(min_tshift_cmt_original,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
-! define topology of the control element
- call hex_nodes(iaddx,iaddy,iaddr)
-
-! initializes source mask
- if( SAVE_SOURCE_MASK .and. SIMULATION_TYPE == 3 ) then
- allocate( mask_source(NGLLX,NGLLY,NGLLZ,NSPEC) )
- mask_source(:,:,:,:) = 1.0_CUSTOM_REAL
- endif
-
-! get MPI starting time for all sources
- time_start = MPI_WTIME()
-
-! loop on all the sources
-! gather source information in subsets to reduce memory requirements
-
-! 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)
- if(ASSUME_PERFECT_SPHERE) then
- theta = PI/2.0d0 - lat(isource)*PI/180.0d0
- else
- theta = PI/2.0d0 - atan(0.99329534d0*dtan(lat(isource)*PI/180.0d0))
- endif
-
- 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)
-
- if(myrank == 0) write(IOVTK,*) sngl(x_target_source),sngl(y_target_source),sngl(z_target_source)
-
-! set distance to huge initial value
- distmin = HUGEVAL
-
-! compute typical size of elements at the surface
- typical_size = TWO_PI * R_UNIT_SPHERE / (4.*NEX_XI)
-
-! use 10 times the distance as a criterion for source detection
- typical_size = 10. * typical_size
-
-! flag to check that we located at least one target element
- located_target = .false.
-
- 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.
-
- ! define the interval in which we look for points
- if(USE_FORCE_POINT_SOURCE) then
- ! force sources will be put on an exact GLL point
- imin = 1
- imax = NGLLX
-
- jmin = 1
- jmax = NGLLY
-
- kmin = 1
- kmax = NGLLZ
-
- else
- ! double-couple CMTSOLUTION
- ! loop only on points inside the element
- ! exclude edges to ensure this point is not shared with other elements
- imin = 2
- imax = NGLLX - 1
-
- jmin = 2
- jmax = NGLLY - 1
-
- kmin = 2
- kmax = NGLLZ - 1
- endif
- do k = kmin,kmax
- do j = jmin,jmax
- do i = imin,imax
-
- ! keep this point if it is closer to the receiver
- iglob = ibool(i,j,k,ispec)
- dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
- +(y_target_source - dble(ystore(iglob)))**2 &
- +(z_target_source - dble(zstore(iglob)))**2)
- if(dist < distmin) then
- distmin = dist
- ispec_selected_source_subset(isource_in_this_subset) = ispec
- ix_initial_guess_source = i
- iy_initial_guess_source = j
- iz_initial_guess_source = k
- endif
-
- enddo
- enddo
- enddo
-
-! calculates a gaussian mask around source point
- if( SAVE_SOURCE_MASK .and. SIMULATION_TYPE == 3 ) then
- call calc_mask_source(mask_source,ispec,NSPEC,typical_size, &
- x_target_source,y_target_source,z_target_source, &
- ibool,xstore,ystore,zstore,NGLOB)
- endif
-
-! 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
-
- ! for point sources, the location will be exactly at a GLL point
- ! otherwise this tries to find best location
- if( USE_FORCE_POINT_SOURCE ) then
- ! store xi,eta,gamma and x,y,z of point found
- ! note: they have range [1.0d0,NGLLX/Y/Z], used for point sources
- ! see e.g. in compute_add_sources.f90
- xi_source_subset(isource_in_this_subset) = dble(ix_initial_guess_source)
- eta_source_subset(isource_in_this_subset) = dble(iy_initial_guess_source)
- gamma_source_subset(isource_in_this_subset) = dble(iz_initial_guess_source)
-
- iglob = ibool(ix_initial_guess_source,iy_initial_guess_source, &
- iz_initial_guess_source,ispec_selected_source_subset(isource_in_this_subset))
- x_found_source(isource_in_this_subset) = xstore(iglob)
- y_found_source(isource_in_this_subset) = ystore(iglob)
- z_found_source(isource_in_this_subset) = zstore(iglob)
-
- ! 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
-
- else
-
- ! 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
-
- endif ! USE_FORCE_POINT_SOURCE
-
-! 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,*)
- ! different output for force point sources
- if(USE_FORCE_POINT_SOURCE) then
- write(IMAIN,*) ' i index of source in that element: ',nint(xi_source(isource))
- write(IMAIN,*) ' j index of source in that element: ',nint(eta_source(isource))
- write(IMAIN,*) ' k index of source in that element: ',nint(gamma_source(isource))
- write(IMAIN,*)
- write(IMAIN,*) ' component direction: ',COMPONENT_FORCE_SOURCE
- write(IMAIN,*)
- write(IMAIN,*) ' nu1 = ',nu_source(1,:,isource)
- write(IMAIN,*) ' nu2 = ',nu_source(2,:,isource)
- write(IMAIN,*) ' nu3 = ',nu_source(3,:,isource)
- write(IMAIN,*)
- write(IMAIN,*) ' at (x,y,z) coordinates = ',x_found_source(isource_in_this_subset),&
- y_found_source(isource_in_this_subset),z_found_source(isource_in_this_subset)
-
- ! prints frequency content for point forces
- f0 = hdur(isource)
- t0_ricker = 1.2d0/f0
- write(IMAIN,*) ' using a source of dominant frequency ',f0
- write(IMAIN,*) ' lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
- write(IMAIN,*) ' lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
- write(IMAIN,*) ' t0_ricker = ',t0_ricker,'tshift_cmt = ',tshift_cmt(isource)
- write(IMAIN,*)
- write(IMAIN,*) ' half duration -> frequency: ',hdur(isource),' seconds**(-1)'
- else
- 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'
- endif
- write(IMAIN,*) ' time shift: ',tshift_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.)
-
- ! define t0 as the earliest start time
- ! note: this calculation here is only used for outputting the plot_source_time_function file
- ! (see setup_sources_receivers.f90)
- t0 = - 1.5d0*minval( tshift_cmt(:) - hdur(:) )
- if( USE_FORCE_POINT_SOURCE ) t0 = - 1.2d0 * minval(tshift_cmt(:) - 1.0d0/hdur(:))
- t_cmt_used(:) = t_cmt_used(:)
- if( USER_T0 > 0.d0 ) then
- if( t0 <= USER_T0 + min_tshift_cmt_original ) then
- t_cmt_used(:) = tshift_cmt(:) + min_tshift_cmt_original
- t0 = USER_T0
- endif
- endif
- ! convert the half duration for triangle STF to the one for gaussian STF
- ! note: this calculation here is only used for outputting the plot_source_time_function file
- ! (see setup_sources_receivers.f90)
- hdur_gaussian(:) = hdur(:)/SOURCE_DECAY_MIMIC_TRIANGLE
-
- ! writes out source time function to file
- do it=1,NSTEP
- time_source = dble(it-1)*DT-t0-t_cmt_used(isource)
- if( USE_FORCE_POINT_SOURCE ) then
- ! Ricker source time function
- f0 = hdur(isource)
- write(27,*) sngl(dble(it-1)*DT-t0), &
- sngl(FACTOR_FORCE_SOURCE*comp_source_time_function_rickr(time_source,f0))
- else
- ! Gaussian source time function
- write(27,*) sngl(dble(it-1)*DT-t0), &
- sngl(scalar_moment*comp_source_time_function(time_source,hdur_gaussian(isource)))
- endif
- enddo
- close(27)
-
- write(IMAIN,*)
- write(IMAIN,*) 'printing the source spectrum'
-
- ! print the spectrum of the derivative of the source from 0 to 1/8 Hz
- if(NSOURCES == 1) then
- plot_file = '/plot_source_spectrum.txt'
- else
- if(isource < 10) then
- write(plot_file,"('/plot_source_spectrum',i1,'.txt')") isource
- 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 !PRINT_SOURCE_TIME_FUNCTION
-
- 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
-
-! stores source mask
- if( SAVE_SOURCE_MASK .and. SIMULATION_TYPE == 3 ) then
- call save_mask_source(myrank,mask_source,NSPEC,LOCAL_PATH)
- deallocate( mask_source )
- endif
-
- end subroutine locate_sources
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine calc_mask_source(mask_source,ispec,NSPEC,typical_size, &
- x_target_source,y_target_source,z_target_source, &
- ibool,xstore,ystore,zstore,NGLOB)
-
-! calculate a gaussian function mask in the crust_mantle region
-! which is 0 around the source locations and 1 everywhere else
-
- implicit none
-
- include "constants.h"
-
- integer :: ispec,NSPEC,NGLOB
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: mask_source
- real(kind=CUSTOM_REAL), dimension(NGLOB) :: xstore,ystore,zstore
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
-
- double precision :: typical_size
- double precision :: x_target_source,y_target_source,z_target_source
-
- ! local parameters
- integer i,j,k,iglob
- double precision dist_sq,sigma_sq
-
- ! standard deviation for gaussian
- ! (removes factor 10 added for search radius from typical_size)
- sigma_sq = typical_size * typical_size / 100.0
-
- ! loops over GLL points within this ispec element
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- ! gets distance (squared) to source
- iglob = ibool(i,j,k,ispec)
- dist_sq = (x_target_source - dble(xstore(iglob)))**2 &
- +(y_target_source - dble(ystore(iglob)))**2 &
- +(z_target_source - dble(zstore(iglob)))**2
-
- ! adds gaussian function value to mask
- ! (mask value becomes 0 closer to source location, 1 everywhere else )
- mask_source(i,j,k,ispec) = mask_source(i,j,k,ispec) &
- * ( 1.0_CUSTOM_REAL - exp( - dist_sq / sigma_sq ) )
-
- enddo
- enddo
- enddo
-
- end subroutine calc_mask_source
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine save_mask_source(myrank,mask_source,NSPEC,LOCAL_PATH)
-
-! saves a mask in the crust_mantle region which is 0 around the source locations
-! and 1 everywhere else
-
- implicit none
-
- include "constants.h"
-
- integer :: myrank,NSPEC
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: mask_source
- character(len=150) :: LOCAL_PATH
-
- ! local parameters
- character(len=150) :: prname
-
- ! stores into file
- call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
- open(unit=27,file=trim(prname)//'mask_source.bin',status='unknown',form='unformatted',action='write')
- write(27) mask_source
- close(27)
-
- end subroutine save_mask_source
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/make_ellipticity.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/make_ellipticity.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/make_ellipticity.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,175 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/make_gravity.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/make_gravity.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/make_gravity.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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 ! PREM moho depth at 24.4 km
- 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/memory_eval.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/memory_eval.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/memory_eval.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,359 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! compute the 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
-! note: the number of transverse isotropic elements is ispec_aniso
-! however for transverse isotropic kernels, the arrays muhstore,kappahstore,eta_anisostore,
-! will be needed for the crust_mantle region everywhere still...
-! originally: NSPECMAX_TISO_MANTLE = ispec_aniso
- NSPECMAX_TISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
- 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 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD)) ) 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
-! rhostore_outer_core,kappavstore_outer_core
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*11.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)
-
-! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ISO_MANTLE*3.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,
-! rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_INNER_CORE)*12.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)
-
-! updated_dof_ocean_load
- static_memory_size = static_memory_size + NGLOB(IREGION_CRUST_MANTLE)*dble(SIZE_LOGICAL)
-
- 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/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1246 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-!
-! United States and French Government Sponsorship Acknowledged.
-
- program xmeshfem3D
-
- use meshfem3D_models_par
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- !include "constants.h"
- include "precision.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 at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @INCOLLECTION{ChKoViCaVaFe07,
-! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
-! Yann Capdeville and Bernard Valette and Gaetano Festa},
-! title = {Spectral Element Analysis in Seismology},
-! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
-! publisher = {Elsevier - Academic Press},
-! year = {2007},
-! editor = {Ru-Shan Wu and Val\'erie Maupin},
-! volume = {48},
-! series = {Advances in Geophysics},
-! pages = {365-419}}
-!
-! @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}}
-!
-! @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{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}}
-!
-! and/or another article from http://web.univ-pau.fr/~dkomati1/publications.html
-!
-!
-! If you use the kernel capabilities of the code, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{LiTr06,
-! author={Qinya Liu and Jeroen Tromp},
-! title={Finite-frequency kernels based on adjoint methods},
-! journal={Bull. Seismol. Soc. Am.},
-! year=2006,
-! volume=96,
-! number=6,
-! pages={2383-2397},
-! doi={10.1785/0120060041}}
-!
-! If you use 3-D model S20RTS, please cite:
-!
-! @ARTICLE{RiVa00,
-! author={J. Ritsema and H. J. {Van Heijst}},
-! year=2000,
-! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
-! journal={Science Progress},
-! volume=83,
-! pages={243-259}}
-!
-! Reference frame - convention:
-! ----------------------------
-!
-! The code uses the following convention for the reference frame:
-!
-! - X axis is East
-! - Y axis is North
-! - Z axis is up
-!
-! Note that this convention is different from both the Aki-Richards convention
-! and the Harvard CMT convention.
-!
-! Let us recall that the Aki-Richards convention is:
-!
-! - X axis is North
-! - Y axis is East
-! - Z axis is down
-!
-! and that the Harvard CMT convention is:
-!
-! - X axis is South
-! - Y axis is East
-! - Z axis is up
-!
-! To report bugs or suggest improvements to the code, please send an email
-! to Jeroen Tromp <jtromp AT princeton.edu> and/or use our online
-! bug tracking system at http://www.geodynamics.org/roundup .
-!
-! Evolution of the code:
-! ---------------------
-!
-! v. 5.1, Dimitri Komatitsch, University of Toulouse, France and Ebru Bozdag, Princeton University, USA, February 2011:
-! non blocking MPI for much better scaling on large clusters;
-! new convention for the name of seismograms, to conform to the IRIS standard;
-! new directory structure
-!
-! v. 5.0 aka Tiger, many developers some with Princeton Tiger logo on their shirts, February 2010:
-! new moho mesh stretching honoring crust2.0 moho depths,
-! new attenuation assignment, new SAC headers, new general crustal models,
-! faster performance due to Deville routines and enhanced loop unrolling,
-! slight changes in code structure
-!
-! 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, one more doubling level at the bottom
-! of the outer core if needed (off by default)
-!
-! 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 CM-5 Connection Machine
-!
-! 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.
-
-
-! 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
- 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
-
-! check area and volume of the final mesh
- double precision area_local_bottom
- double precision area_local_top
- double precision volume_local,volume_total
-
- !integer iprocnum
-
-! for loop on all the slices
- integer iregion_code
- integer iproc_xi,iproc_eta,ichunk
-
-! rotation matrix from Euler angles
- double precision, dimension(NDIM,NDIM) :: rotation_matrix
-
- double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
-
-! 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, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- RMOHO_FICTITIOUS_IN_MESHER
-
- logical MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,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
-
- 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
-
-! 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
-
- integer :: ipass
-
- 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
-
-! this for non blocking MPI
- logical, dimension(:), allocatable :: is_on_a_slice_edge
-
-! ************** PROGRAM STARTS HERE **************
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-! trivia about the programming style adopted here
-!
-! note 1: in general, we do not use modules in the fortran codes. this seems to
-! be mainly a performance reason. changing the codes to adopt modules
-! will have to prove that it performs as fast as it does without now.
-!
-! another reason why modules are avoided, is to make the code thread safe.
-! having different threads access the same data structure and modifying it at the same time
-! would lead to problems. passing arguments is a way to avoid such complications.
-!
-! however, the mesher makes one exception here: it uses the
-! module "meshfem3D_models_par" defined in the 'meshfem3D_models.f90' file.
-! the exception is based on the fact, that when one wants to incorporate
-! a new 3D/1D velocity model, it became tedious to change so many routines hardly
-! related to any model specific need.
-!
-! note 2: adding a new velocity model should become easier. the module tries to help with
-! that task. basically, you would follow the comments "ADD YOUR MODEL HERE"
-! to have an idea where you will have to put some new code:
-!
-! - meshfem3D_models.f90: main file for models
-! put your model structure into the module "meshfem3D_models_par"
-! and add your specific routine calls to get 1D/3D/attenuation values.
-!
-! - get_model_parameters.f90:
-! set your specific model flags and radii
-!
-! - read_compute_parameters.f90:
-! some models need to explicitly set smaller time steps which
-! can be done in routine rcp_set_timestep_and_layers()
-!
-! - add your model implementation into a new file named model_***.f90:
-! in general, this file should have as first routine the model_***_broadcast() routine
-! implemented which deals with passing the model structure to all processes.
-! this involves reading in model specific data which is normally put in directory DATA/
-! then follows a routine that returns the velocity values
-! (as perturbation to the associated 1D reference model) for a given point location.
-!
-! finally, in order to compile the new mesher with your new file(s),
-! you will add it to the list in the 'Makefile.in' file and run
-! `configure` to recreate a new Makefile.
-!
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
-! 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
- ! reads the parameter file and computes additional parameters
- call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX, &
- NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,&
- this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube, &
- HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE, &
- USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
-
- if(err_occurred() /= 0) &
- call exit_MPI(myrank,'an error occurred while reading the parameter file')
-
- endif
-
- ! distributes parameters from master to all processes
- call broadcast_compute_parameters(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- RMOHO_FICTITIOUS_IN_MESHER, &
- MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
- LOCAL_PATH,MODEL, &
- 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, &
- ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
- HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
- ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY)
-
- ! check that the code is running with the requested number of processes
- if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
-
- ! 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)
-
- ! dynamic allocation of mesh arrays
- allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1))
- allocate(ichunk_slice(0:NPROCTOT-1))
- allocate(iproc_xi_slice(0:NPROCTOT-1))
- allocate(iproc_eta_slice(0:NPROCTOT-1))
-
- ! creates global slice addressing for solver
- call meshfem3D_create_addressing(myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT, &
- addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
- OUTPUT_FILES)
-
-
- ! this for the different counters (which are now different if the superbrick is cut in the outer core)
- call meshfem3D_setup_counters(myrank, &
- NSPEC1D_RADIAL,NSPEC2D_XI,NSPEC2D_ETA,NGLOB1D_RADIAL, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- NPROCTOT,iproc_xi_slice,iproc_eta_slice, &
- NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE, &
- NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
-
- ! user output
- if(myrank == 0) call meshfem3D_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT, &
- R_CENTRAL_CUBE)
-
- ! distributes 3D models
- call meshfem3D_models_broadcast(myrank,NSPEC, &
- MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,&
- R80,R220,R670,RCMB,RICB)
-
-
- if(myrank == 0 ) then
- write(IMAIN,*)
- write(IMAIN,*) 'model setup successfully read in'
- write(IMAIN,*)
- endif
-
- ! get addressing for this process
- ichunk = ichunk_slice(myrank)
- iproc_xi = iproc_xi_slice(myrank)
- iproc_eta = iproc_eta_slice(myrank)
-
- ! 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
-!----
-
- ! 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
- allocate(idoubling(NSPEC(iregion_code)))
- allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
- allocate(xstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
- allocate(ystore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
- allocate(zstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
-
-! this for non blocking MPI
- allocate(is_on_a_slice_edge(NSPEC(iregion_code)))
-
- ! create all the regions of the mesh
- ! perform two passes in this part to be able to save memory
- do ipass = 1,2
-
- call create_regions_mesh(iregion_code,ibool,idoubling,is_on_a_slice_edge, &
- xstore,ystore,zstore,rmins,rmaxs, &
- iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_aniso, &
- volume_local,area_local_bottom,area_local_top, &
- 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), &
- NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE, &
- NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
- myrank,LOCAL_PATH,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
- SAVE_MESH_FILES,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
- 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,ipass,ratio_divide_central_cube, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2))
-
- enddo
-
- ! 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')
-
- ! computes total area and volume
- call meshfem3D_compute_area(myrank,NCHUNKS,iregion_code, &
- area_local_bottom,area_local_top,&
- volume_local,volume_total, &
- RCMB,RICB,R_CENTRAL_CUBE)
-
- ! create chunk buffers if more than one chunk
- if(NCHUNKS > 1) then
- call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool,idoubling, &
- 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)
- 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
- deallocate(idoubling)
- deallocate(ibool)
- deallocate(xstore)
- deallocate(ystore)
- deallocate(zstore)
-
-! this for non blocking MPI
- deallocate(is_on_a_slice_edge)
-
- ! make sure everybody is synchronized
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-! end of loop on all the regions
- enddo
-
- if(myrank == 0) then
- ! check volume of chunk
- write(IMAIN,*)
- write(IMAIN,*) 'calculated volume: ',volume_total
- if(.not. TOPOGRAPHY) then
- ! take the central cube into account
- ! it is counted 6 times because of the fictitious elements
- if(INCLUDE_CENTRAL_CUBE) then
- write(IMAIN,*) ' exact volume: ', &
- dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)+5.*(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
- else
- write(IMAIN,*) ' exact volume: ', &
- dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)-(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
- endif
- endif
- endif
-
-
-!--- print number of points and elements in the mesh for each region
-
- if(myrank == 0) then
-
- numelem_crust_mantle = NSPEC(IREGION_CRUST_MANTLE)
- numelem_outer_core = NSPEC(IREGION_OUTER_CORE)
- numelem_inner_core = NSPEC(IREGION_INNER_CORE)
-
- numelem_total = numelem_crust_mantle + numelem_outer_core + numelem_inner_core
-
- write(IMAIN,*)
- write(IMAIN,*) 'Repartition of elements in regions:'
- write(IMAIN,*) '----------------------------------'
- write(IMAIN,*)
- write(IMAIN,*) 'total number of elements in each slice: ',numelem_total
- write(IMAIN,*)
- write(IMAIN,*) ' - crust and mantle: ',sngl(100.d0*dble(numelem_crust_mantle)/dble(numelem_total)),' %'
- write(IMAIN,*) ' - outer core: ',sngl(100.d0*dble(numelem_outer_core)/dble(numelem_total)),' %'
- write(IMAIN,*) ' - inner core: ',sngl(100.d0*dble(numelem_inner_core)/dble(numelem_total)),' %'
- write(IMAIN,*)
- write(IMAIN,*) 'for some mesh statistics, see comments in file OUTPUT_FILES/values_from_mesher.h'
- write(IMAIN,*)
-
- ! load balancing
- write(IMAIN,*) 'Load balancing = 100 % by definition'
- write(IMAIN,*)
-
- write(IMAIN,*)
- write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
- write(IMAIN,*)
-
- write(IMAIN,*)
- write(IMAIN,*) 'time-stepping of the solver will be: ',DT
- write(IMAIN,*)
-
- ! write information about precision used for floating-point operations
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IMAIN,*) 'using single precision for the calculations'
- else
- write(IMAIN,*) 'using double precision for the calculations'
- endif
- write(IMAIN,*)
- write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
- write(IMAIN,*)
-
- ! 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,OCEANS,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, &
- SIMULATION_TYPE,SAVE_FORWARD,MOVIE_VOLUME,NOISE_TOMOGRAPHY)
-
- endif ! end of section executed by main process only
-
- ! deallocate arrays used for mesh generation
- 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)
-
- ! stop all the MPI processes, and exit
- call MPI_FINALIZE(ier)
-
- end program xmeshfem3D
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine meshfem3D_create_addressing(myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT, &
- addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
- OUTPUT_FILES)
-
- implicit none
-
- include "constants.h"
-
- integer :: myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT
-
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
- integer, dimension(0:NPROCTOT-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
-
- character(len=150) OUTPUT_FILES
-
- ! local parameters
- integer ichunk,iproc_eta,iproc_xi,iprocnum,ier
-
- ! initializes
- 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
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/addressing.txt',status='unknown',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening addressing.txt')
- 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
- if(myrank == 0) write(IOUT,*) iprocnum,ichunk,iproc_xi,iproc_eta
- enddo
- enddo
- enddo
-
- if(myrank == 0) close(IOUT)
-
- end subroutine meshfem3D_create_addressing
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine meshfem3D_setup_counters(myrank, &
- NSPEC1D_RADIAL,NSPEC2D_XI,NSPEC2D_ETA,NGLOB1D_RADIAL, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- NPROCTOT,iproc_xi_slice,iproc_eta_slice, &
- NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE, &
- NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
-
-! returns: NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE,
-! NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER
-
- implicit none
-
- include "constants.h"
-
- integer myrank
-
-! this for all the regions
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL
-
- 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
-
- ! addressing for all the slices
- integer :: NPROCTOT
- integer, dimension(0:NPROCTOT-1) :: iproc_xi_slice,iproc_eta_slice
-
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
-
-! 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
-
-
- ! local parameters
- integer :: iregion
-
- 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
-
- end subroutine meshfem3D_setup_counters
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine meshfem3D_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT,&
- R_CENTRAL_CUBE)
-
- use meshfem3D_models_par
-
- implicit none
-
- integer :: myrank,sizeprocs,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT
- double precision :: R_CENTRAL_CUBE
-
- 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,*)
- 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(HETEROGEN_3D_MANTLE) then
- write(IMAIN,*) 'incorporating heterogeneities in the mantle'
- else
- write(IMAIN,*) 'no heterogeneities in the mantle'
- 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,*)
- if(ANISOTROPIC_INNER_CORE) then
- write(IMAIN,*) 'incorporating anisotropic inner core'
- else
- write(IMAIN,*) 'no inner-core anisotropy'
- endif
- write(IMAIN,*)
- if(ANISOTROPIC_3D_MANTLE) then
- write(IMAIN,*) 'incorporating anisotropic mantle'
- else
- write(IMAIN,*) 'no general mantle anisotropy'
- endif
- write(IMAIN,*)
- 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'
-
- end subroutine meshfem3D_output_info
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine meshfem3D_compute_area(myrank,NCHUNKS,iregion_code, &
- area_local_bottom,area_local_top,&
- volume_local,volume_total, &
- RCMB,RICB,R_CENTRAL_CUBE)
-
- use meshfem3D_models_par
-
- implicit none
-
- include 'mpif.h'
-
- integer :: myrank,NCHUNKS,iregion_code
-
- double precision :: area_local_bottom,area_local_top,volume_local
- double precision :: volume_total
- double precision :: RCMB,RICB,R_CENTRAL_CUBE
-
- ! local parameters
- double precision :: volume_total_region,area_total_bottom,area_total_top
- integer :: ier
-
- ! 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,*) ' similar 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
-
-
- end subroutine meshfem3D_compute_area
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D_models.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D_models.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D_models.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1381 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
- module meshfem3D_models_par
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
- implicit none
-
- include "constants.h"
-
-! model_aniso_mantle_variables
- type model_aniso_mantle_variables
- sequence
- double precision beta(14,34,37,73)
- double precision pro(47)
- integer npar1
- integer dummy_pad ! padding 4 bytes to align the structure
- end type model_aniso_mantle_variables
- type (model_aniso_mantle_variables) AMM_V
-! model_aniso_mantle_variables
-
-! model_attenuation_variables
- type model_attenuation_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
- 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, dimension(:), pointer :: interval_Q ! Steps
- integer :: Qn ! Number of points
- integer dummy_pad ! padding 4 bytes to align the structure
- end type model_attenuation_variables
- type (model_attenuation_variables) AM_V
-! model_attenuation_variables
-
-! model_atten3D_QRFSI12_variables
- type model_atten3D_QRFSI12_variables
- sequence
- double precision dqmu(NKQ,NSQ)
- double precision spknt(NKQ)
- double precision refdepth(NDEPTHS_REFQ)
- double precision refqmu(NDEPTHS_REFQ)
- end type model_atten3D_QRFSI12_variables
- type (model_atten3D_QRFSI12_variables) QRFSI12_Q
-! model_atten3D_QRFSI12_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_1dref_variables
- type model_1dref_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_1dref_variables
- type (model_1dref_variables) Mref_V
-! model_1dref_variables
-
-! model_sea1d_variables
- type model_sea1d_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 model_sea1d_variables
- type (model_sea1d_variables) SEA1DM_V
-! model_sea1d_variables
-
-! model_s20rts_variables
- type model_s20rts_variables
- sequence
- double precision dvs_a(0:NK_20,0:NS_20,0:NS_20) !a = positive m (radial, theta, phi) --> (k,l,m) (maybe other way around??)
- double precision dvs_b(0:NK_20,0:NS_20,0:NS_20) !b = negative m (radial, theta, phi) --> (k,l,-m)
- double precision dvp_a(0:NK_20,0:NS_20,0:NS_20)
- double precision dvp_b(0:NK_20,0:NS_20,0:NS_20)
- double precision spknt(NK_20+1)
- double precision qq0(NK_20+1,NK_20+1)
- double precision qq(3,NK_20+1,NK_20+1)
- end type model_s20rts_variables
- type (model_s20rts_variables) S20RTS_V
-! model_s20rts_variables
-
-! model_s40rts_variables
- type model_s40rts_variables
- sequence
- double precision dvs_a(0:NK_20,0:NS_40,0:NS_40)
- double precision dvs_b(0:NK_20,0:NS_40,0:NS_40)
- double precision dvp_a(0:NK_20,0:NS_40,0:NS_40)
- double precision dvp_b(0:NK_20,0:NS_40,0:NS_40)
- double precision spknt(NK_20+1)
- double precision qq0(NK_20+1,NK_20+1)
- double precision qq(3,NK_20+1,NK_20+1)
- end type model_s40rts_variables
- type (model_s40rts_variables) S40RTS_V
-! model_s40rts_variables
-
-! model_heterogen_m_variables
- type model_heterogen_m_variables
- sequence
- double precision rho_in(N_R*N_THETA*N_PHI)
- end type model_heterogen_m_variables
- type (model_heterogen_m_variables) HMM
-! model_heterogen_m_variables
-
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
-
-! model_sea99_s_variables
- type model_sea99_s_variables
- sequence
- double precision :: sea99_vs(100,100,100)
- double precision :: sea99_depth(100)
- double precision :: sea99_ddeg
- double precision :: alatmin
- double precision :: alatmax
- double precision :: alonmin
- double precision :: alonmax
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_sea99_s_variables
- type (model_sea99_s_variables) SEA99M_V
-! model_sea99_s_variables
-
-! crust 2.0 model_crust_variables
- type model_crust_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)
- character(len=2) dummy_pad ! padding 2 bytes to align the structure
- end type model_crust_variables
- type (model_crust_variables) CM_V
-! model_crust_variables
-
-! EUcrust
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
-! model_crustmaps_variables combined crustal maps
- type model_crustmaps_variables
- sequence
- double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
- double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
- double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
- double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
- double precision thicknessnp(NLAYERS_CRUSTMAP)
- double precision densitynp(NLAYERS_CRUSTMAP)
- double precision velocpnp(NLAYERS_CRUSTMAP)
- double precision velocsnp(NLAYERS_CRUSTMAP)
- double precision thicknesssp(NLAYERS_CRUSTMAP)
- double precision densitysp(NLAYERS_CRUSTMAP)
- double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
- end type model_crustmaps_variables
- type (model_crustmaps_variables) GC_V
-!model_crustmaps_variables
-
-! model_attenuation_storage_var
- type model_attenuation_storage_var
- sequence
- double precision, dimension(:,:), pointer :: tau_e_storage
- double precision, dimension(:), pointer :: Qmu_storage
- integer Q_resolution
- integer Q_max
- end type model_attenuation_storage_var
- type (model_attenuation_storage_var) AM_S
-! model_attenuation_storage_var
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- 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
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- end type attenuation_simplex_variables
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
-! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
-
-! GLL model_variables
- type model_gll_variables
- sequence
- ! tomographic iteration model on GLL points
- double precision :: scale_velocity,scale_density
- ! isotropic model
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vs_new,vp_new,rho_new
- ! transverse isotropic model
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vsv_new,vpv_new, &
- vsh_new,vph_new,eta_new
- logical :: MODEL_GLL
- logical,dimension(3) :: dummy_pad ! padding 3 bytes to align the structure
- end type model_gll_variables
- type (model_gll_variables) MGLL_V
-
-! bathymetry and topography: use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
-! used for 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
- integer, parameter :: maxker=200
- integer, parameter :: maxl=72
- integer, parameter :: maxcoe=2000
- integer, parameter :: maxver=1000
- integer, parameter :: maxhpa=2
-
- 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)
-
- 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)
- integer numker
- integer numhpa,numcof
- integer ihpa,lmax,nylm
-
- character(len=80) kerstr
- character(len=80) refmdl
- character(len=40) varstr(maxker)
- character(len=80) hsplfl(maxhpa)
- character(len=40) dskker(maxker)
-
-
-! for ellipticity
- double precision rspl(NR),espl(NR),espl2(NR)
- integer nspl
-
-! model parameter and flags
- integer REFERENCE_1D_MODEL,THREE_D_MODEL
-
- logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS
-
- logical HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY
-
- logical ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE
-
- logical ATTENUATION,ATTENUATION_3D
-
- logical ANISOTROPIC_INNER_CORE
-
- end module meshfem3D_models_par
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine meshfem3D_models_broadcast(myrank,NSPEC, &
- MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,&
- R80,R220,R670,RCMB,RICB)
-
-! preparing model parameter coefficients on all processes
-
- use meshfem3D_models_par
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- integer myrank
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC
-
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
-
- double precision R80,R220,R670,RCMB,RICB
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
- ! sets up spline coefficients for ellipticity
- if(ELLIPTICITY) &
- call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
-
- ! GLL model uses s29ea as reference 3D model
- if( THREE_D_MODEL == THREE_D_MODEL_GLL ) then
- MGLL_V%MODEL_GLL = .true.
- THREE_D_MODEL = THREE_D_MODEL_S29EA
- else
- MGLL_V%MODEL_GLL = .false.
- endif
-
- ! reads in 3D mantle models
- if(ISOTROPIC_3D_MANTLE) then
-
- select case( THREE_D_MODEL )
-
- case(THREE_D_MODEL_S20RTS)
- call model_s20rts_broadcast(myrank,S20RTS_V)
-
- case(THREE_D_MODEL_S40RTS)
- call model_s40rts_broadcast(myrank,S40RTS_V)
-
- case(THREE_D_MODEL_SEA99_JP3D)
- ! the variables read are declared and stored in structure SEA99M_V and JP3DM_V
- call model_sea99_s_broadcast(myrank,SEA99M_V)
- call model_jp3d_broadcast(myrank,JP3DM_V)
-
- case(THREE_D_MODEL_SEA99)
- ! the variables read are declared and stored in structure SEA99M_V
- call model_sea99_s_broadcast(myrank,SEA99M_V)
-
- case(THREE_D_MODEL_JP3D)
- ! the variables read are declared and stored in structure JP3DM_V
- call model_jp3d_broadcast(myrank,JP3DM_V)
-
- case(THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
- THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA)
- call model_s362ani_broadcast(myrank,THREE_D_MODEL,numker,numhpa,ihpa,&
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
- xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
-
- case(THREE_D_MODEL_PPM)
- ! Point Profile Models
- ! the variables read are declared and stored in structure PPM_V
- call model_ppm_broadcast(myrank,PPM_V)
-
- ! could use EUcrust07 Vp crustal structure
- !call model_eucrust_broadcast(myrank,EUCM_V)
-
- case(THREE_D_MODEL_GAPP2)
- ! GAP model
- call model_gapp2_broadcast(myrank)
-
- case default
- call exit_MPI(myrank,'3D model not defined')
-
- end select
-
- endif
-
- ! arbitrary mantle models
- if(HETEROGEN_3D_MANTLE) &
- call model_heterogen_mntl_broadcast(myrank,HMM)
-
- ! anisotropic mantle
- if(ANISOTROPIC_3D_MANTLE) &
- call model_aniso_mantle_broadcast(myrank,AMM_V)
-
- ! crustal model
- if(CRUSTAL) &
- call meshfem3D_crust_broadcast(myrank)
-
- ! GLL model
- if( MGLL_V%MODEL_GLL ) &
- call model_gll_broadcast(myrank,MGLL_V,NSPEC)
-
- ! attenuation
- if(ATTENUATION ) then
- call model_attenuation_broadcast(myrank,AM_V,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD)
-
- ! 3D attenuation
- if( ATTENUATION_3D) then
- ! Colleen's model defined originally between 24.4km and 650km
- call model_atten3D_QRFSI12_broadcast(myrank,QRFSI12_Q)
- else
- ! sets up attenuation coefficients according to the chosen, "pure" 1D model
- ! (including their 1D-crustal profiles)
- call model_attenuation_setup(REFERENCE_1D_MODEL, RICB, RCMB, &
- R670, R220, R80,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,AM_S,AS_V)
- endif
-
- endif
-
- ! read topography and bathymetry file
- if(TOPOGRAPHY .or. OCEANS) &
- call model_topo_bathy_broadcast(myrank,ibathy_topo)
-
- ! re-defines/initializes models 1066a and ak135 and ref
- ! ( with possible external crustal model: if CRUSTAL is set to true
- ! it strips the 1-D crustal profile and replaces it with mantle properties)
- select case( REFERENCE_1D_MODEL )
-
- case(REFERENCE_MODEL_1066A)
- call model_1066a_broadcast(CRUSTAL,M1066a_V)
-
- case( REFERENCE_MODEL_AK135)
- call model_ak135_broadcast(CRUSTAL,Mak135_V)
-
- case(REFERENCE_MODEL_1DREF)
- call model_1dref_broadcast(CRUSTAL,Mref_V)
-
- case(REFERENCE_MODEL_SEA1D)
- call model_sea1d_broadcast(CRUSTAL,SEA1DM_V)
-
- end select
-
- end subroutine meshfem3D_models_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine meshfem3D_crust_broadcast(myrank)
-
-! preparing model parameter coefficients on all processes
-
- use meshfem3D_models_par
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- integer myrank
-
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
- select case (ITYPE_CRUSTAL_MODEL )
-
- case (ICRUST_CRUST2)
- ! crust 2.0
- call model_crust_broadcast(myrank,CM_V)
-
- case (ICRUST_CRUSTMAPS)
- ! general crustmaps
- call model_crustmaps_broadcast(myrank,GC_V)
-
- case default
- stop 'crustal model type not defined'
-
- end select
-
-
- end subroutine meshfem3D_crust_broadcast
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine meshfem3D_models_get1D_val(myrank,iregion_code,idoubling, &
- r_prem,rho,vpv,vph,vsv,vsh,eta_aniso, &
- Qkappa,Qmu,RICB,RCMB, &
- RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
- RMOHO,RMIDDLE_CRUST,ROCEAN)
-! reference model values
-!
-! for a given location radius (r_prem, which is the point's radius with tolerance factor),
-! this calculates density and velocities
-!
-! note: if CRUSTAL is set, it strips the 1-D crustal profile and mantle gets expanded
-! up to the surface.
-! only exception is JP1D...
-!
-! routine returns: rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu
-
- use meshfem3D_models_par
-
- implicit none
-
- integer myrank,iregion_code,idoubling
- double precision r_prem,rho
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision Qkappa,Qmu
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R80,R120,R220,R400, &
- R600,R670,R771,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- ! local parameters
- double precision drhodr,vp,vs
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
- ! gets 1-D reference model parameters
- select case ( REFERENCE_1D_MODEL )
-
- case(REFERENCE_MODEL_PREM)
- ! PREM (by Dziewonski & Anderson) - used also as background for 3D models
- if(TRANSVERSE_ISOTROPY) then
- ! get the anisotropic PREM parameters
- call model_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
- ! isotropic model
- call model_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)
- endif
-
- case(REFERENCE_MODEL_1DREF)
- ! 1D-REF also known as STW105 (by Kustowski et al.) - used also as background for 3D models
- call model_1dref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
- if(.not. TRANSVERSE_ISOTROPY) then
- if(.not. ISOTROPIC_3D_MANTLE) then
- ! this case here is only executed for 1D_ref_iso
- ! calculates isotropic values
- vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
- + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
- vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
- + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
- endif
- endif
-
- case(REFERENCE_MODEL_1066A)
- ! 1066A (by Gilbert & Dziewonski) - pure isotropic model, used in 1D model mode only
- call model_1066a(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V)
-
- case(REFERENCE_MODEL_AK135)
- ! AK135 (by Kennett et al. ) - pure isotropic model, used in 1D model mode only
- call model_ak135(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V)
-
- case(REFERENCE_MODEL_IASP91)
- ! IASP91 (by Kennett & Engdahl) - pure isotropic model, used in 1D model mode only
- 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)
-
- case(REFERENCE_MODEL_JP1D)
- !JP1D (by Zhao et al.) - pure isotropic model, used also as background for 3D models
- call model_jp1d(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
- .true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
-
- case(REFERENCE_MODEL_SEA1D)
- ! SEA1D (by Lebedev & Nolet) - pure isotropic model, used also as background for 3D models
- call model_sea1d(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
-
- case default
- stop 'unknown 1D reference Earth model in meshfem3D_models_get1D_val()'
-
- end select
-
- ! needs to set vpv,vph,vsv,vsh and eta_aniso for isotropic models
- if( .not. TRANSVERSE_ISOTROPY ) then
- ! in the case of s362iso we want to save the anisotropic constants for the Voight average
- if(.not. (REFERENCE_1D_MODEL == REFERENCE_MODEL_1DREF .and. ISOTROPIC_3D_MANTLE)) then
- vpv = vp
- vph = vp
- vsv = vs
- vsh = vs
- eta_aniso = 1.d0
- endif
- endif ! TRANSVERSE_ISOTROPY
-
- end subroutine meshfem3D_models_get1D_val
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine meshfem3D_models_get3Dmntl_val(iregion_code,r_prem,rho,dvp,&
- vpv,vph,vsv,vsh,eta_aniso, &
- RCMB,R670,RMOHO, &
- xmesh,ymesh,zmesh,r, &
- c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
- c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
-
- use meshfem3D_models_par
-
- implicit none
-
- integer iregion_code
- double precision r_prem
- double precision rho,dvp
- double precision vpv,vph,vsv,vsh,eta_aniso
-
- double precision RCMB,R670,RMOHO
- double precision xmesh,ymesh,zmesh,r
-
- ! 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
-
- ! local parameters
- double precision :: r_used,r_dummy,theta,phi
- double precision :: dvs,drho,vp,vs
- real(kind=4) :: xcolat,xlon,xrad,dvpv,dvph,dvsv,dvsh
- logical :: found_crust,suppress_mantle_extension
-
- ! initializes perturbation values
- dvs = ZERO
- dvp = ZERO
- drho = ZERO
- dvpv = 0.
- dvph = 0.
- dvsv = 0.
- dvsh = 0.
- r_used = ZERO
- suppress_mantle_extension = .false.
-
- ! gets point's theta/phi
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
- call reduce(theta,phi)
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
- ! sets flag when mantle should not be extended to surface
- if(r_prem >= RMOHO/R_EARTH .and. .not. CRUSTAL) then
- suppress_mantle_extension = .true.
- endif
-
- ! gets parameters for isotropic 3D mantle model
- !
- ! note: there can be tranverse isotropy in the mantle, but only lamé parameters
- ! like kappav,kappah,muv,muh and eta_aniso are used for these simulations
- !
- ! note: in general, models here make use of perturbation values with respect to their
- ! corresponding 1-D reference models
- if( ISOTROPIC_3D_MANTLE .and. r_prem > RCMB/R_EARTH .and. .not. suppress_mantle_extension) then
-
- ! extend 3-D mantle model above the Moho to the surface before adding the crust
- if(r_prem > RCMB/R_EARTH .and. r_prem < RMOHO/R_EARTH) then
- ! GLL point is in mantle region, takes exact location
- r_used = r
- else ! else if(r_prem >= RMOHO/R_EARTH) then
- if( CRUSTAL ) then
- ! GLL point is above moho
- ! takes radius slightly below moho radius, this will then "extend the mantle up to the surface";
- ! crustal values will be superimposed later on
- r_used = 0.999999d0*RMOHO/R_EARTH
- endif
- endif
-
- ! gets model parameters
- select case( THREE_D_MODEL )
-
- case(THREE_D_MODEL_S20RTS)
- ! s20rts
- call mantle_s20rts(r_used,theta,phi,dvs,dvp,drho,S20RTS_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)
-
- case(THREE_D_MODEL_S40RTS)
- ! s40rts
- call mantle_s40rts(r_used,theta,phi,dvs,dvp,drho,S40RTS_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)
-
- case(THREE_D_MODEL_SEA99_JP3D)
- ! sea99 + jp3d1994
- call model_sea99_s(r_used,theta,phi,dvs,SEA99M_V)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- ! use Lebedev model sea99 as background and add vp & vs perturbation from Zhao 1994 model jp3d
- 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_used > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
- call model_jp3d_iso_zhao(r_used,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
-
- case(THREE_D_MODEL_SEA99)
- ! sea99 Vs-only
- call model_sea99_s(r_used,theta,phi,dvs,SEA99M_V)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
-
- case(THREE_D_MODEL_JP3D)
- ! jp3d1994
- 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_used > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
- call model_jp3d_iso_zhao(r_used,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
-
- case(THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
- THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA)
- ! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
- xcolat = sngl(theta*180.0d0/PI)
- xlon = sngl(phi*180.0d0/PI)
- xrad = sngl(r_used*R_EARTH_KM)
- call model_s362ani_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
-
- case(THREE_D_MODEL_PPM )
- ! point profile model
- call model_PPM(r_used,theta,phi,dvs,dvp,drho,PPM_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)
-
- case(THREE_D_MODEL_GAPP2 )
- ! 3D GAP model (Obayashi)
- call mantle_gapmodel(r_used,theta,phi,dvs,dvp,drho)
- 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)
-
- case default
- stop 'unknown 3D Earth model in meshfem3D_models_get3Dmntl_val() '
-
- end select ! THREE_D_MODEL
-
- endif ! ISOTROPIC_3D_MANTLE
-
- ! heterogen model
- if( HETEROGEN_3D_MANTLE .and. .not. suppress_mantle_extension ) then
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_used,theta,phi)
- call reduce(theta,phi)
- call model_heterogen_mantle(r_used,theta,phi,dvs,dvp,drho,HMM)
- vpv=vpv*(1.0d0+dvp)
- vph=vpv*(1.0d0+dvp)
- vsv=vsv*(1.0d0+dvs)
- vsh=vsh*(1.0d0+dvs)
- rho=rho*(1.0d0+drho)
- endif ! HETEROGEN_3D_MANTLE
-
- if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) &
- call model_aniso_inner_core(r_prem,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL, &
- vpv,vph,vsv,vsh,rho,eta_aniso)
-
- 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 > R670/R_EARTH .and. .not. suppress_mantle_extension ) then
-
- ! extend 3-D mantle model above the Moho to the surface before adding the crust
- if( r_prem < RMOHO/R_EARTH) then
- r_used = r_prem
- else
- if( CRUSTAL ) then
- ! fills 3-D mantle model above the Moho with the values at moho depth
- r_used = RMOHO/R_EARTH
- endif
- endif
- call model_aniso_mantle(r_used,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)
-
- else
- ! fills the rest of the mantle with the isotropic model
- c11 = rho*vpv*vpv
- c12 = rho*(vpv*vpv-2.*vsv*vsv)
- c13 = c12
- c14 = 0.d0
- c15 = 0.d0
- c16 = 0.d0
- c22 = c11
- c23 = c12
- c24 = 0.d0
- c25 = 0.d0
- c26 = 0.d0
- c33 = c11
- c34 = 0.d0
- c35 = 0.d0
- c36 = 0.d0
- c44 = rho*vsv*vsv
- c45 = 0.d0
- c46 = 0.d0
- c55 = c44
- c56 = 0.d0
- c66 = c44
- endif
- endif ! ANISOTROPIC_3D_MANTLE
-
-!> Hejun
-! Assign Attenuation after get 3-D crustal model
-! This is here to identify how and where to include 3D attenuation
-! if(ATTENUATION .and. ATTENUATION_3D) then
-! call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
-! call reduce(theta,phi)
-! theta_degrees = theta / DEGREES_TO_RADIANS
-! phi_degrees = phi / DEGREES_TO_RADIANS
-! tau_e(:) = 0.0d0
-! ! Get the value of Qmu (Attenuation) dependedent on
-! ! the radius (r_prem) and idoubling flag
-! !call model_attenuation_1D_PREM(r_prem, Qmu, idoubling)
-! call model_atten3D_QRFSI12(r_prem*R_EARTH_KM,theta_degrees,phi_degrees,Qmu,QRFSI12_Q,idoubling)
-! ! Get tau_e from tau_s and Qmu
-! call model_attenuation_getstored_tau(Qmu, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
-! endif
-
- end subroutine meshfem3D_models_get3Dmntl_val
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine meshfem3D_models_get3Dcrust_val(iregion_code,xmesh,ymesh,zmesh,r, &
- vpv,vph,vsv,vsh,rho,eta_aniso,dvp, &
- c11,c12,c13,c14,c15,c16,c22,c23,c24,c25, &
- c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66, &
- elem_in_crust,moho)
-
-! returns velocities and density for points in 3D crustal region
-
- use meshfem3D_models_par
-
- implicit none
-
- integer iregion_code
- ! note: r is the exact radius (and not r_prem with tolerance)
- double precision xmesh,ymesh,zmesh,r
- double precision vpv,vph,vsv,vsh,rho,eta_aniso,dvp
-
- ! 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
-
- logical elem_in_crust
- double precision moho
-
- ! local parameters
- double precision :: r_dummy,theta,phi
- double precision :: lat,lon
- double precision :: vpc,vsc,rhoc !,vpc_eu
- double precision :: dvs
- logical :: found_crust !,found_eucrust
-
- ! checks if anything to do, that is, there is nothing to do
- ! for point radius smaller than deepest possible crust radius (~80 km depth)
- if( r < R_DEEPEST_CRUST ) return
-
- ! gets point's position theta/phi, lat/lon
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
- call reduce(theta,phi)
- lat = (PI/2.0d0-theta)*180.0d0/PI
- lon = phi*180.0d0/PI
- if(lon>180.0d0) lon = lon-360.0d0
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
- ! crustal model can vary for different 3-D models
- select case (THREE_D_MODEL )
-
- case(THREE_D_MODEL_SEA99_JP3D,THREE_D_MODEL_JP3D)
- ! tries to use Zhao's model of the crust
- 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
- ! makes sure radius is fine
- if(r > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
- call model_jp3d_iso_zhao(r,theta,phi,vpc,vsc,dvp,dvs,rhoc,found_crust,JP3DM_V)
- endif
- else
- ! default crust
- call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
- endif
-
- case ( THREE_D_MODEL_PPM )
- ! takes vs,rho from default crust
- call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
-
- ! takes vp from eucrust07
- !call model_eucrust(lat,lon,r,vpc_eu,found_eucrust,EUCM_V)
- !if( found_eucrust) then
- ! vpc=vpc_eu
- !endif
-
- case default
- ! default crust
- call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
-
- end select
-
- ! sets crustal values
- if( found_crust ) then
- vpv=vpc
- vph=vpc
- vsv=vsc
- vsh=vsc
- rho=rhoc
- eta_aniso=1.0d0
-
- ! sets anisotropy in crustal region as well
- 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
-
- end subroutine meshfem3D_models_get3Dcrust_val
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
-
-! returns velocity/density for default crust
-
- use meshfem3D_models_par
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- !integer myrank
- double precision,intent(in) :: lat,lon,r
- double precision,intent(out) :: vpc,vsc,rhoc
- double precision,intent(out) :: moho
- logical,intent(out) :: found_crust
- logical,intent(in) :: elem_in_crust
-
- ! initializes
- vpc = 0.d0
- vsc = 0.d0
- rhoc = 0.d0
- moho = 0.d0
- found_crust = .false.
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
- select case (ITYPE_CRUSTAL_MODEL )
-
- case (ICRUST_CRUST2)
- ! crust 2.0
- call model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V,elem_in_crust)
-
- case (ICRUST_CRUSTMAPS)
- ! general crustmaps
- call model_crustmaps(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,GC_V,elem_in_crust)
-
- case default
- stop 'crustal model type not defined'
-
- end select
-
-
- end subroutine meshfem3D_model_crust
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine meshfem3D_models_getatten_val(idoubling,xmesh,ymesh,zmesh,r_prem, &
- tau_e,tau_s,T_c_source, &
- moho,Qmu,Qkappa,elem_in_crust)
-
-! sets attenuation values tau_e and Qmu for a given point
-!
-! note: only Qmu attenuation considered, Qkappa attenuation not used so far in solver...
-
- use meshfem3D_models_par
-
- implicit none
-
- integer idoubling
-
- double precision xmesh,ymesh,zmesh
-
- double precision r_prem
- double precision moho
-
- ! attenuation values
- double precision Qkappa,Qmu
- double precision, dimension(N_SLS) :: tau_s, tau_e
- double precision T_c_source
-
- logical elem_in_crust
-
- ! local parameters
- double precision r_dummy,theta,phi,theta_degrees,phi_degrees
- double precision, parameter :: rmoho_prem = 6371.0-24.4
- double precision r_used
-
- ! initializes
- tau_e(:) = 0.0d0
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
- ! Get the value of Qmu (Attenuation) dependent on
- ! the radius (r_prem) and idoubling flag
- if (ATTENUATION_3D) then
- ! used for models: s362ani_3DQ, s362iso_3DQ, 3D_attenuation
-
- ! gets spherical coordinates
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
- call reduce(theta,phi)
- theta_degrees = theta / DEGREES_TO_RADIANS
- phi_degrees = phi / DEGREES_TO_RADIANS
-
- ! in case models incorporate a 3D crust, attenuation values for mantle
- ! get expanded up to surface, and for the crustal points Qmu for PREM crust is imposed
- r_used = r_prem*R_EARTH_KM
- if( CRUSTAL ) then
- if ( r_prem > (ONE-moho) .or. elem_in_crust) then
- ! points in actual crust: puts point radius into prem crust
- r_used = rmoho_prem*1.0001
- else if( r_prem*R_EARTH_KM >= rmoho_prem ) then
- ! points below actual crust (e.g. oceanic crust case), but above prem moho:
- ! puts point slightly below prem moho to expand mantle values at that depth
- r_used = rmoho_prem*0.99999
- endif
- endif ! CRUSTAL
-
- ! gets value according to radius/theta/phi location and idoubling flag
- call model_atten3D_QRFSI12(r_used,theta_degrees,phi_degrees,Qmu,QRFSI12_Q,idoubling)
-
- else
-
- select case (REFERENCE_1D_MODEL)
-
- ! case(REFERENCE_MODEL_PREM)
- ! this case is probably not needed since Qmu is 600. between R80 and surface
- ! call model_attenuation_1D_PREM(r_prem, Qmu)
-
- case(REFERENCE_MODEL_1DREF)
- ! 1D Ref changes Qmu at moho depth of 24.4km
- ! we take the crustal value and assign it to points only inside actual crust,
- ! otherwise the mantle values is taken
- ! makes sense especially for points below thin oceanic and thick continental crust
- if ( CRUSTAL ) then
- ! takes crustal Q value only if point is in actual crust
- if ( r_prem > (ONE-moho) .or. elem_in_crust) then
- ! reference from 1D-REF aka STW105
- Qmu=300.0d0
- Qkappa=57822.5d0 ! not used so far...
- endif
- endif ! CRUSTAL
-
- case(REFERENCE_MODEL_SEA1D)
- ! SEA1D changes Qmu at 25km (moho) depth. we take the crustal value
- ! for points only inside actual crust
- if ( CRUSTAL ) then
- ! takes crustal Q value only if point is in actual crust
- if ( r_prem > (ONE-moho) .or. elem_in_crust) then
- ! reference from Sea1D
- Qmu = 300.0d0
- Qkappa = 57822.5d0 ! not used so far...
- endif
- endif
-
- end select
-
- end if
-
- ! Get tau_e from tau_s and Qmu
- call model_attenuation_getstored_tau(Qmu, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
-
- end subroutine meshfem3D_models_getatten_val
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine meshfem3D_models_impose_val(vpv,vph,vsv,vsh,rho,dvp,eta_aniso,&
- myrank,iregion_code,ispec,i,j,k)
-
-! overwrites values with updated model values (from iteration step) here, given at all GLL points
-
- use meshfem3D_models_par
-
- implicit none
-
- double precision :: vpv,vph,vsv,vsh,rho,dvp,eta_aniso
- integer :: myrank,iregion_code,ispec,i,j,k
-
- ! local parameters
- double precision :: vp,vs
-
- ! model GLL
- if( MGLL_V%MODEL_GLL .and. iregion_code == IREGION_CRUST_MANTLE ) then
-
- ! isotropic model
- if( .not. TRANSVERSE_ISOTROPY ) then
-
- !check
- if( ispec > size(MGLL_V%vp_new(1,1,1,:)) ) then
- call exit_MPI(myrank,'model gll: ispec too big')
- endif
-
- ! takes stored gll values from file
- ! ( note that these values are non-dimensionalized)
- if(CUSTOM_REAL == SIZE_REAL) then
- vp = dble( MGLL_V%vp_new(i,j,k,ispec) )
- vs = dble( MGLL_V%vs_new(i,j,k,ispec) )
- rho = dble( MGLL_V%rho_new(i,j,k,ispec) )
- else
- vp = MGLL_V%vp_new(i,j,k,ispec)
- vs = MGLL_V%vs_new(i,j,k,ispec)
- rho = MGLL_V%rho_new(i,j,k,ispec)
- endif
- ! isotropic model
- vpv = vp
- vph = vp
- vsv = vs
- vsh = vs
- rho = rho
- eta_aniso = 1.0d0
-
- ! transverse isotropic model
- else
-
- !check
- if( ispec > size(MGLL_V%vpv_new(1,1,1,:)) ) then
- call exit_MPI(myrank,'model gll: ispec too big')
- endif
-
- ! takes stored gll values from file
- if(CUSTOM_REAL == SIZE_REAL) then
- vph = dble( MGLL_V%vph_new(i,j,k,ispec) )
- vpv = dble( MGLL_V%vpv_new(i,j,k,ispec) )
- vsh = dble( MGLL_V%vsh_new(i,j,k,ispec) )
- vsv = dble( MGLL_V%vsv_new(i,j,k,ispec) )
- rho = dble( MGLL_V%rho_new(i,j,k,ispec) )
- eta_aniso = dble( MGLL_V%eta_new(i,j,k,ispec) )
- else
- vph = MGLL_V%vph_new(i,j,k,ispec)
- vpv = MGLL_V%vpv_new(i,j,k,ispec)
- vsh = MGLL_V%vsh_new(i,j,k,ispec)
- vsv = MGLL_V%vsv_new(i,j,k,ispec)
- rho = MGLL_V%rho_new(i,j,k,ispec)
- eta_aniso = MGLL_V%eta_new(i,j,k,ispec)
- endif
- endif
- ! no mantle vp perturbation
- dvp = 0.0d0
-
- endif ! MODEL_GLL
-
- end subroutine meshfem3D_models_impose_val
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_1066a.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_1066a.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_1066a.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1173 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! 1066A
-!
-! Spherically symmetric earth model 1066A [Gilbert and Dziewonski, 1975].
-!
-! When ATTENTUATION is on, it uses an unpublished 1D attenuation model from Scripps.
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_1066a_broadcast(CRUSTAL,M1066a_V)
-
-! standard routine to setup model
-
- 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 :: CRUSTAL
-
- ! all processes will define same parameters
- call define_model_1066a(CRUSTAL, M1066a_V)
-
- end subroutine model_1066a_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- 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 (SUPPRESS_CRUSTAL_MESH .or. 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/model_1dref.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_1dref.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_1dref.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,7442 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-!
-! 1D REF model of Kustowski et al. (2008)
-!
-! this is STW105 - new reference model, also known as REF
-!
-! A recent 1D Earth model developed by Kustowski et al. This model is the 1D background
-! model for the 3D models s362ani, s362wmani, s362ani_prem, and s29ea.
-!
-! see chapter 3, in:
-! Kustowski, B, Ekstrom, G., and A. M. Dziewonski, 2008,
-! Anisotropic shear-wave velocity structure of the Earth's mantle: A global model,
-! J. Geophys. Res., 113, B06306, doi:10.1029/2007JB005169.
-!
-! model is identical to PREM at crustal depths, between 220 and 400km
-! and below 670km.
-!
-! attenuation structure is taken from model QL6:
-! Durek, J. J. and G. Ekström, 1996.
-! A radial model of anelasticity consistent with long period surface wave attenuation,
-! Bull. Seism. Soc. Am., 86, 144-158
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_1dref_broadcast(CRUSTAL,Mref_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
-
- ! model_1dref_variables
- type model_1dref_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_1dref_variables
-
- type (model_1dref_variables) Mref_V
- ! model_1dref_variables
-
- logical :: CRUSTAL
-
- ! all processes will define same parameters
- call define_model_1dref(CRUSTAL,Mref_V)
-
- end subroutine model_1dref_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine model_1dref(x,rho,vpv,vph,vsv,vsh,eta,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
-
- implicit none
-
- include "constants.h"
-
-! model_1dref_variables
- type model_1dref_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_1dref_variables
-
- type (model_1dref_variables) Mref_V
-! model_1dref_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 model is used, mantle gets expanded up to surface
- ! for any depth less than 24.4 km, values from mantle below moho are taken
- if(CRUSTAL .and. i > 717) i = 717
-
-
- if(i == 1) then
- ! first layer in inner core
- 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
- ! interpolates between one layer below to actual radius layer,
- ! that is 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))
- ! interpolated model parameters
- 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_1dref
-
-!-------------------
-
- subroutine define_model_1dref(USE_EXTERNAL_CRUSTAL_MODEL,Mref_V)
-
- implicit none
- include "constants.h"
-
-! model_1dref_variables
- type model_1dref_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_1dref_variables
-
- type (model_1dref_variables) Mref_V
-! model_1dref_variables
-
- logical USE_EXTERNAL_CRUSTAL_MODEL
-
-
-! 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 /)
-
-! strip the crust and replace it by mantle
- if (SUPPRESS_CRUSTAL_MESH .or. USE_EXTERNAL_CRUSTAL_MODEL) then
- ! sets values for depths less than 24.4 km to mantle values below
- 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)
- Mref_V%Qmu_ref(718:750) = Mref_V%Qmu_ref(717)
- Mref_V%Qkappa_ref(718:750) = Mref_V%Qkappa_ref(717)
- endif
-
-
- end subroutine define_model_1dref
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_ak135.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_ak135.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_ak135.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1021 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! AK135
-!
-! Spherically symmetric isotropic AK135 model [Kennett et al., 1995].
-!
-! B. L. N. Kennett, E. R. Engdahl and R. Buland,
-! Constraints on seismic velocities in the Earth from traveltimes,
-! Geophysical Journal International, Volume 122, Issue 1, Pages 1-351 (1995),
-! DOI: 10.1111/j.1365-246X.1995.tb03540.x
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_ak135_broadcast(CRUSTAL,Mak135_V)
-
-! standard routine to setup model
-
- 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 :: CRUSTAL
-
- ! all processes will define same parameters
- call define_model_ak135(CRUSTAL, Mak135_V)
-
- end subroutine model_ak135_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- 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
-
-! 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 > 24) i = 24
-
- if(iregion_code == IREGION_OUTER_CORE .and. i < 26) i = 26
- if(iregion_code == IREGION_OUTER_CORE .and. i > 69) i = 69
-
- if(iregion_code == IREGION_CRUST_MANTLE .and. i < 71) i = 71
-
- 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
-
-! define all the values in the model
-
- Mak135_V%radius_ak135( 1) = 0.000000000000000E+000
- 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) = 659260.000000000
- Mak135_V%radius_ak135( 14) = 710000.000000000
- Mak135_V%radius_ak135( 15) = 760690.000000000
- Mak135_V%radius_ak135( 16) = 811400.000000000
- Mak135_V%radius_ak135( 17) = 862110.000000000
- Mak135_V%radius_ak135( 18) = 912830.000000000
- Mak135_V%radius_ak135( 19) = 963540.000000000
- Mak135_V%radius_ak135( 20) = 1014250.00000000
- Mak135_V%radius_ak135( 21) = 1064960.00000000
- Mak135_V%radius_ak135( 22) = 1115680.00000000
- Mak135_V%radius_ak135( 23) = 1166390.00000000
- Mak135_V%radius_ak135( 24) = 1217500.00000000
- Mak135_V%radius_ak135( 25) = 1217500.00000000
- Mak135_V%radius_ak135( 26) = 1267430.00000000
- Mak135_V%radius_ak135( 27) = 1317760.00000000
- Mak135_V%radius_ak135( 28) = 1368090.00000000
- Mak135_V%radius_ak135( 29) = 1418420.00000000
- Mak135_V%radius_ak135( 30) = 1468760.00000000
- Mak135_V%radius_ak135( 31) = 1519090.00000000
- Mak135_V%radius_ak135( 32) = 1569420.00000000
- Mak135_V%radius_ak135( 33) = 1670080.00000000
- Mak135_V%radius_ak135( 34) = 1720410.00000000
- Mak135_V%radius_ak135( 35) = 1770740.00000000
- Mak135_V%radius_ak135( 36) = 1821070.00000000
- Mak135_V%radius_ak135( 37) = 1871400.00000000
- Mak135_V%radius_ak135( 38) = 1921740.00000000
- Mak135_V%radius_ak135( 39) = 1972070.00000000
- Mak135_V%radius_ak135( 40) = 2022400.00000000
- Mak135_V%radius_ak135( 41) = 2072730.00000000
- Mak135_V%radius_ak135( 42) = 2123060.00000000
- Mak135_V%radius_ak135( 43) = 2173390.00000000
- Mak135_V%radius_ak135( 44) = 2223720.00000000
- Mak135_V%radius_ak135( 45) = 2274050.00000000
- Mak135_V%radius_ak135( 46) = 2324380.00000000
- Mak135_V%radius_ak135( 47) = 2374720.00000000
- Mak135_V%radius_ak135( 48) = 2425050.00000000
- Mak135_V%radius_ak135( 49) = 2475380.00000000
- Mak135_V%radius_ak135( 50) = 2525710.00000000
- Mak135_V%radius_ak135( 51) = 2576040.00000000
- Mak135_V%radius_ak135( 52) = 2626370.00000000
- Mak135_V%radius_ak135( 53) = 2676700.00000000
- Mak135_V%radius_ak135( 54) = 2727030.00000000
- Mak135_V%radius_ak135( 55) = 2777360.00000000
- Mak135_V%radius_ak135( 56) = 2827700.00000000
- Mak135_V%radius_ak135( 57) = 2878030.00000000
- Mak135_V%radius_ak135( 58) = 2928360.00000000
- Mak135_V%radius_ak135( 59) = 2978690.00000000
- Mak135_V%radius_ak135( 60) = 3029020.00000000
- Mak135_V%radius_ak135( 61) = 3079350.00000000
- Mak135_V%radius_ak135( 62) = 3129680.00000000
- Mak135_V%radius_ak135( 63) = 3180010.00000000
- Mak135_V%radius_ak135( 64) = 3230340.00000000
- Mak135_V%radius_ak135( 65) = 3280680.00000000
- Mak135_V%radius_ak135( 66) = 3331010.00000000
- Mak135_V%radius_ak135( 67) = 3381340.00000000
- Mak135_V%radius_ak135( 68) = 3431670.00000000
- Mak135_V%radius_ak135( 69) = 3479500.00000000
- Mak135_V%radius_ak135( 70) = 3479500.00000000
- Mak135_V%radius_ak135( 71) = 3531670.00000000
- Mak135_V%radius_ak135( 72) = 3581330.00000000
- Mak135_V%radius_ak135( 73) = 3631000.00000000
- Mak135_V%radius_ak135( 74) = 3631000.00000000
- Mak135_V%radius_ak135( 75) = 3681000.00000000
- Mak135_V%radius_ak135( 76) = 3731000.00000000
- Mak135_V%radius_ak135( 77) = 3779500.00000000
- Mak135_V%radius_ak135( 78) = 3829000.00000000
- Mak135_V%radius_ak135( 79) = 3878500.00000000
- Mak135_V%radius_ak135( 80) = 3928000.00000000
- Mak135_V%radius_ak135( 81) = 3977500.00000000
- Mak135_V%radius_ak135( 82) = 4027000.00000000
- Mak135_V%radius_ak135( 83) = 4076500.00000000
- Mak135_V%radius_ak135( 84) = 4126000.00000000
- Mak135_V%radius_ak135( 85) = 4175500.00000000
- Mak135_V%radius_ak135( 86) = 4225000.00000000
- Mak135_V%radius_ak135( 87) = 4274500.00000000
- Mak135_V%radius_ak135( 88) = 4324000.00000000
- Mak135_V%radius_ak135( 89) = 4373500.00000000
- Mak135_V%radius_ak135( 90) = 4423000.00000000
- Mak135_V%radius_ak135( 91) = 4472500.00000000
- Mak135_V%radius_ak135( 92) = 4522000.00000000
- Mak135_V%radius_ak135( 93) = 4571500.00000000
- Mak135_V%radius_ak135( 94) = 4621000.00000000
- Mak135_V%radius_ak135( 95) = 4670500.00000000
- Mak135_V%radius_ak135( 96) = 4720000.00000000
- Mak135_V%radius_ak135( 97) = 4769500.00000000
- Mak135_V%radius_ak135( 98) = 4819000.00000000
- Mak135_V%radius_ak135( 99) = 4868500.00000000
- Mak135_V%radius_ak135(100) = 4918000.00000000
- Mak135_V%radius_ak135(101) = 4967500.00000000
- Mak135_V%radius_ak135(102) = 5017000.00000000
- Mak135_V%radius_ak135(103) = 5066500.00000000
- Mak135_V%radius_ak135(104) = 5116000.00000000
- Mak135_V%radius_ak135(105) = 5165500.00000000
- Mak135_V%radius_ak135(106) = 5215000.00000000
- Mak135_V%radius_ak135(107) = 5264500.00000000
- Mak135_V%radius_ak135(108) = 5314000.00000000
- Mak135_V%radius_ak135(109) = 5363500.00000000
- Mak135_V%radius_ak135(110) = 5413000.00000000
- Mak135_V%radius_ak135(111) = 5462500.00000000
- Mak135_V%radius_ak135(112) = 5512000.00000000
- Mak135_V%radius_ak135(113) = 5561500.00000000
- Mak135_V%radius_ak135(114) = 5611000.00000000
- Mak135_V%radius_ak135(115) = 5661000.00000000
- Mak135_V%radius_ak135(116) = 5711000.00000000
- Mak135_V%radius_ak135(117) = 5711000.00000000
- Mak135_V%radius_ak135(118) = 5761000.00000000
- Mak135_V%radius_ak135(119) = 5811000.00000000
- Mak135_V%radius_ak135(120) = 5861000.00000000
- Mak135_V%radius_ak135(121) = 5911000.00000000
- Mak135_V%radius_ak135(122) = 5961000.00000000
- Mak135_V%radius_ak135(123) = 5961000.00000000
- Mak135_V%radius_ak135(124) = 6011000.00000000
- Mak135_V%radius_ak135(125) = 6061000.00000000
- Mak135_V%radius_ak135(126) = 6111000.00000000
- Mak135_V%radius_ak135(127) = 6161000.00000000
- Mak135_V%radius_ak135(128) = 6161000.00000000
- Mak135_V%radius_ak135(129) = 6206000.00000000
- Mak135_V%radius_ak135(130) = 6251000.00000000
- Mak135_V%radius_ak135(131) = 6293500.00000000
- Mak135_V%radius_ak135(132) = 6336000.00000000
- Mak135_V%radius_ak135(133) = 6336000.00000000
- Mak135_V%radius_ak135(134) = 6351000.00000000
- Mak135_V%radius_ak135(135) = 6351000.00000000
- Mak135_V%radius_ak135(136) = 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.9217000000000
- Mak135_V%density_ak135( 14) = 12.9070000000000
- Mak135_V%density_ak135( 15) = 12.8917000000000
- Mak135_V%density_ak135( 16) = 12.8751000000000
- Mak135_V%density_ak135( 17) = 12.8574000000000
- Mak135_V%density_ak135( 18) = 12.8387000000000
- Mak135_V%density_ak135( 19) = 12.8188000000000
- Mak135_V%density_ak135( 20) = 12.7980000000000
- Mak135_V%density_ak135( 21) = 12.7760000000000
- Mak135_V%density_ak135( 22) = 12.7530000000000
- Mak135_V%density_ak135( 23) = 12.7289000000000
- Mak135_V%density_ak135( 24) = 12.7037000000000
- Mak135_V%density_ak135( 25) = 12.1391000000000
- Mak135_V%density_ak135( 26) = 12.1133000000000
- Mak135_V%density_ak135( 27) = 12.0867000000000
- Mak135_V%density_ak135( 28) = 12.0593000000000
- Mak135_V%density_ak135( 29) = 12.0311000000000
- Mak135_V%density_ak135( 30) = 12.0001000000000
- Mak135_V%density_ak135( 31) = 11.9722000000000
- Mak135_V%density_ak135( 32) = 11.9414000000000
- Mak135_V%density_ak135( 33) = 11.8772000000000
- Mak135_V%density_ak135( 34) = 11.8437000000000
- Mak135_V%density_ak135( 35) = 11.8092000000000
- Mak135_V%density_ak135( 36) = 11.7737000000000
- Mak135_V%density_ak135( 37) = 11.7373000000000
- Mak135_V%density_ak135( 38) = 11.6998000000000
- Mak135_V%density_ak135( 39) = 11.6612000000000
- Mak135_V%density_ak135( 40) = 11.6216000000000
- Mak135_V%density_ak135( 41) = 11.5809000000000
- Mak135_V%density_ak135( 42) = 11.5391000000000
- Mak135_V%density_ak135( 43) = 11.4962000000000
- Mak135_V%density_ak135( 44) = 11.4521000000000
- Mak135_V%density_ak135( 45) = 11.4069000000000
- Mak135_V%density_ak135( 46) = 11.3604000000000
- Mak135_V%density_ak135( 47) = 11.3127000000000
- Mak135_V%density_ak135( 48) = 11.2639000000000
- Mak135_V%density_ak135( 49) = 11.2137000000000
- Mak135_V%density_ak135( 50) = 11.1623000000000
- Mak135_V%density_ak135( 51) = 11.1095000000000
- Mak135_V%density_ak135( 52) = 11.0555000000000
- Mak135_V%density_ak135( 53) = 11.0001000000000
- Mak135_V%density_ak135( 54) = 10.9434000000000
- Mak135_V%density_ak135( 55) = 10.8852000000000
- Mak135_V%density_ak135( 56) = 10.8257000000000
- Mak135_V%density_ak135( 57) = 10.7647000000000
- Mak135_V%density_ak135( 58) = 10.7023000000000
- Mak135_V%density_ak135( 59) = 10.6385000000000
- Mak135_V%density_ak135( 60) = 10.5731000000000
- Mak135_V%density_ak135( 61) = 10.5062000000000
- Mak135_V%density_ak135( 62) = 10.4378000000000
- Mak135_V%density_ak135( 63) = 10.3679000000000
- Mak135_V%density_ak135( 64) = 10.2964000000000
- Mak135_V%density_ak135( 65) = 10.2233000000000
- Mak135_V%density_ak135( 66) = 10.1485000000000
- Mak135_V%density_ak135( 67) = 10.0722000000000
- Mak135_V%density_ak135( 68) = 9.99420000000000
- Mak135_V%density_ak135( 69) = 9.91450000000000
- Mak135_V%density_ak135( 70) = 5.77210000000000
- Mak135_V%density_ak135( 71) = 5.74580000000000
- Mak135_V%density_ak135( 72) = 5.71960000000000
- Mak135_V%density_ak135( 73) = 5.69340000000000
- Mak135_V%density_ak135( 74) = 5.43870000000000
- Mak135_V%density_ak135( 75) = 5.41760000000000
- Mak135_V%density_ak135( 76) = 5.39620000000000
- Mak135_V%density_ak135( 77) = 5.37480000000000
- Mak135_V%density_ak135( 78) = 5.35310000000000
- Mak135_V%density_ak135( 79) = 5.33130000000000
- Mak135_V%density_ak135( 80) = 5.30920000000000
- Mak135_V%density_ak135( 81) = 5.28700000000000
- Mak135_V%density_ak135( 82) = 5.26460000000000
- Mak135_V%density_ak135( 83) = 5.24200000000000
- Mak135_V%density_ak135( 84) = 5.21920000000000
- Mak135_V%density_ak135( 85) = 5.19630000000000
- Mak135_V%density_ak135( 86) = 5.17320000000000
- Mak135_V%density_ak135( 87) = 5.14990000000000
- Mak135_V%density_ak135( 88) = 5.12640000000000
- Mak135_V%density_ak135( 89) = 5.10270000000000
- Mak135_V%density_ak135( 90) = 5.07890000000000
- Mak135_V%density_ak135( 91) = 5.05480000000000
- Mak135_V%density_ak135( 92) = 5.03060000000000
- Mak135_V%density_ak135( 93) = 5.00620000000000
- Mak135_V%density_ak135( 94) = 4.98170000000000
- Mak135_V%density_ak135( 95) = 4.95700000000000
- Mak135_V%density_ak135( 96) = 4.93210000000000
- Mak135_V%density_ak135( 97) = 4.90690000000000
- Mak135_V%density_ak135( 98) = 4.88170000000000
- Mak135_V%density_ak135( 99) = 4.85620000000000
- Mak135_V%density_ak135(100) = 4.83070000000000
- Mak135_V%density_ak135(101) = 4.80500000000000
- Mak135_V%density_ak135(102) = 4.77900000000000
- Mak135_V%density_ak135(103) = 4.75280000000000
- Mak135_V%density_ak135(104) = 4.72660000000000
- Mak135_V%density_ak135(105) = 4.70010000000000
- Mak135_V%density_ak135(106) = 4.67350000000000
- Mak135_V%density_ak135(107) = 4.64670000000000
- Mak135_V%density_ak135(108) = 4.61980000000000
- Mak135_V%density_ak135(109) = 4.59260000000000
- Mak135_V%density_ak135(110) = 4.56540000000000
- Mak135_V%density_ak135(111) = 4.51620000000000
- Mak135_V%density_ak135(112) = 4.46500000000000
- Mak135_V%density_ak135(113) = 4.41180000000000
- Mak135_V%density_ak135(114) = 4.35650000000000
- Mak135_V%density_ak135(115) = 4.29860000000000
- Mak135_V%density_ak135(116) = 4.23870000000000
- Mak135_V%density_ak135(117) = 3.92010000000000
- Mak135_V%density_ak135(118) = 3.92060000000000
- Mak135_V%density_ak135(119) = 3.92180000000000
- Mak135_V%density_ak135(120) = 3.92330000000000
- Mak135_V%density_ak135(121) = 3.92730000000000
- Mak135_V%density_ak135(122) = 3.93170000000000
- Mak135_V%density_ak135(123) = 3.50680000000000
- Mak135_V%density_ak135(124) = 3.45770000000000
- Mak135_V%density_ak135(125) = 3.41100000000000
- Mak135_V%density_ak135(126) = 3.36630000000000
- Mak135_V%density_ak135(127) = 3.32430000000000
- Mak135_V%density_ak135(128) = 3.32430000000000
- Mak135_V%density_ak135(129) = 3.37110000000000
- Mak135_V%density_ak135(130) = 3.42680000000000
- Mak135_V%density_ak135(131) = 3.34500000000000
- Mak135_V%density_ak135(132) = 3.32000000000000
- Mak135_V%density_ak135(133) = 2.92000000000000
- Mak135_V%density_ak135(134) = 2.92000000000000
- Mak135_V%density_ak135(135) = 2.72000000000000
- Mak135_V%density_ak135(136) = 2.72000000000000
-
- 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.1941000000000
- Mak135_V%vp_ak135( 14) = 11.1830000000000
- Mak135_V%vp_ak135( 15) = 11.1715000000000
- Mak135_V%vp_ak135( 16) = 11.1590000000000
- Mak135_V%vp_ak135( 17) = 11.1457000000000
- Mak135_V%vp_ak135( 18) = 11.1316000000000
- Mak135_V%vp_ak135( 19) = 11.1166000000000
- Mak135_V%vp_ak135( 20) = 11.0983000000000
- Mak135_V%vp_ak135( 21) = 11.0850000000000
- Mak135_V%vp_ak135( 22) = 11.0718000000000
- Mak135_V%vp_ak135( 23) = 11.0585000000000
- Mak135_V%vp_ak135( 24) = 11.0427000000000
- Mak135_V%vp_ak135( 25) = 10.2890000000000
- Mak135_V%vp_ak135( 26) = 10.2854000000000
- Mak135_V%vp_ak135( 27) = 10.2745000000000
- Mak135_V%vp_ak135( 28) = 10.2565000000000
- Mak135_V%vp_ak135( 29) = 10.2329000000000
- Mak135_V%vp_ak135( 30) = 10.2049000000000
- Mak135_V%vp_ak135( 31) = 10.1739000000000
- Mak135_V%vp_ak135( 32) = 10.1415000000000
- Mak135_V%vp_ak135( 33) = 10.0768000000000
- Mak135_V%vp_ak135( 34) = 10.0439000000000
- Mak135_V%vp_ak135( 35) = 10.0103000000000
- Mak135_V%vp_ak135( 36) = 9.97610000000000
- Mak135_V%vp_ak135( 37) = 9.94100000000000
- Mak135_V%vp_ak135( 38) = 9.90510000000000
- Mak135_V%vp_ak135( 39) = 9.86820000000000
- Mak135_V%vp_ak135( 40) = 9.83040000000000
- Mak135_V%vp_ak135( 41) = 9.79140000000000
- Mak135_V%vp_ak135( 42) = 9.75130000000000
- Mak135_V%vp_ak135( 43) = 9.71000000000000
- Mak135_V%vp_ak135( 44) = 9.66730000000000
- Mak135_V%vp_ak135( 45) = 9.62320000000000
- Mak135_V%vp_ak135( 46) = 9.57770000000000
- Mak135_V%vp_ak135( 47) = 9.53060000000000
- Mak135_V%vp_ak135( 48) = 9.48140000000000
- Mak135_V%vp_ak135( 49) = 9.42970000000000
- Mak135_V%vp_ak135( 50) = 9.37600000000000
- Mak135_V%vp_ak135( 51) = 9.32050000000000
- Mak135_V%vp_ak135( 52) = 9.26340000000000
- Mak135_V%vp_ak135( 53) = 9.20420000000000
- Mak135_V%vp_ak135( 54) = 9.14260000000000
- Mak135_V%vp_ak135( 55) = 9.07920000000000
- Mak135_V%vp_ak135( 56) = 9.01380000000000
- Mak135_V%vp_ak135( 57) = 8.94610000000000
- Mak135_V%vp_ak135( 58) = 8.87610000000000
- Mak135_V%vp_ak135( 59) = 8.80360000000000
- Mak135_V%vp_ak135( 60) = 8.72830000000000
- Mak135_V%vp_ak135( 61) = 8.64960000000000
- Mak135_V%vp_ak135( 62) = 8.56920000000000
- Mak135_V%vp_ak135( 63) = 8.48610000000000
- Mak135_V%vp_ak135( 64) = 8.40010000000000
- Mak135_V%vp_ak135( 65) = 8.31220000000000
- Mak135_V%vp_ak135( 66) = 8.22130000000000
- Mak135_V%vp_ak135( 67) = 8.12830000000000
- Mak135_V%vp_ak135( 68) = 8.03820000000000
- Mak135_V%vp_ak135( 69) = 8.00000000000000
- Mak135_V%vp_ak135( 70) = 13.6601000000000
- Mak135_V%vp_ak135( 71) = 13.6570000000000
- Mak135_V%vp_ak135( 72) = 13.6533000000000
- Mak135_V%vp_ak135( 73) = 13.6498000000000
- Mak135_V%vp_ak135( 74) = 13.6498000000000
- Mak135_V%vp_ak135( 75) = 13.5899000000000
- Mak135_V%vp_ak135( 76) = 13.5311000000000
- Mak135_V%vp_ak135( 77) = 13.4741000000000
- Mak135_V%vp_ak135( 78) = 13.4156000000000
- Mak135_V%vp_ak135( 79) = 13.3584000000000
- Mak135_V%vp_ak135( 80) = 13.3017000000000
- Mak135_V%vp_ak135( 81) = 13.2465000000000
- Mak135_V%vp_ak135( 82) = 13.1895000000000
- Mak135_V%vp_ak135( 83) = 13.1337000000000
- Mak135_V%vp_ak135( 84) = 13.0786000000000
- Mak135_V%vp_ak135( 85) = 13.0226000000000
- Mak135_V%vp_ak135( 86) = 12.9663000000000
- Mak135_V%vp_ak135( 87) = 12.9093000000000
- Mak135_V%vp_ak135( 88) = 12.8524000000000
- Mak135_V%vp_ak135( 89) = 12.7956000000000
- Mak135_V%vp_ak135( 90) = 12.7384000000000
- Mak135_V%vp_ak135( 91) = 12.6807000000000
- Mak135_V%vp_ak135( 92) = 12.6226000000000
- Mak135_V%vp_ak135( 93) = 12.5638000000000
- Mak135_V%vp_ak135( 94) = 12.5030000000000
- Mak135_V%vp_ak135( 95) = 12.4427000000000
- Mak135_V%vp_ak135( 96) = 12.3813000000000
- Mak135_V%vp_ak135( 97) = 12.3181000000000
- Mak135_V%vp_ak135( 98) = 12.2558000000000
- Mak135_V%vp_ak135( 99) = 12.1912000000000
- Mak135_V%vp_ak135(100) = 12.1247000000000
- Mak135_V%vp_ak135(101) = 12.0571000000000
- Mak135_V%vp_ak135(102) = 11.9891000000000
- Mak135_V%vp_ak135(103) = 11.9208000000000
- Mak135_V%vp_ak135(104) = 11.8491000000000
- Mak135_V%vp_ak135(105) = 11.7768000000000
- Mak135_V%vp_ak135(106) = 11.7020000000000
- Mak135_V%vp_ak135(107) = 11.6265000000000
- Mak135_V%vp_ak135(108) = 11.5493000000000
- Mak135_V%vp_ak135(109) = 11.4704000000000
- Mak135_V%vp_ak135(110) = 11.3897000000000
- Mak135_V%vp_ak135(111) = 11.3068000000000
- Mak135_V%vp_ak135(112) = 11.2228000000000
- Mak135_V%vp_ak135(113) = 11.1355000000000
- Mak135_V%vp_ak135(114) = 11.0553000000000
- Mak135_V%vp_ak135(115) = 10.9222000000000
- Mak135_V%vp_ak135(116) = 10.7909000000000
- Mak135_V%vp_ak135(117) = 10.2000000000000
- Mak135_V%vp_ak135(118) = 10.0320000000000
- Mak135_V%vp_ak135(119) = 9.86400000000000
- Mak135_V%vp_ak135(120) = 9.69620000000000
- Mak135_V%vp_ak135(121) = 9.52800000000000
- Mak135_V%vp_ak135(122) = 9.36010000000000
- Mak135_V%vp_ak135(123) = 9.03020000000000
- Mak135_V%vp_ak135(124) = 8.84760000000000
- Mak135_V%vp_ak135(125) = 8.66500000000000
- Mak135_V%vp_ak135(126) = 8.48220000000000
- Mak135_V%vp_ak135(127) = 8.30070000000000
- Mak135_V%vp_ak135(128) = 8.30070000000000
- Mak135_V%vp_ak135(129) = 8.17500000000000
- Mak135_V%vp_ak135(130) = 8.05050000000000
- Mak135_V%vp_ak135(131) = 8.04500000000000
- Mak135_V%vp_ak135(132) = 8.04000000000000
- Mak135_V%vp_ak135(133) = 6.50000000000000
- Mak135_V%vp_ak135(134) = 6.50000000000000
- Mak135_V%vp_ak135(135) = 5.80000000000000
- Mak135_V%vp_ak135(136) = 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.62020000000000
- Mak135_V%vs_ak135( 14) = 3.61300000000000
- Mak135_V%vs_ak135( 15) = 3.60440000000000
- Mak135_V%vs_ak135( 16) = 3.59570000000000
- Mak135_V%vs_ak135( 17) = 3.58640000000000
- Mak135_V%vs_ak135( 18) = 3.57650000000000
- Mak135_V%vs_ak135( 19) = 3.56610000000000
- Mak135_V%vs_ak135( 20) = 3.55510000000000
- Mak135_V%vs_ak135( 21) = 3.54350000000000
- Mak135_V%vs_ak135( 22) = 3.53140000000000
- Mak135_V%vs_ak135( 23) = 3.51870000000000
- Mak135_V%vs_ak135( 24) = 3.50430000000000
- Mak135_V%vs_ak135( 25) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 26) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 27) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 28) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 29) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 30) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 31) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 32) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 33) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 34) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 35) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 36) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 37) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 38) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 39) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 40) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 41) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 42) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 43) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 44) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 45) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 46) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 47) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 48) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 49) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 50) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 51) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 52) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 53) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 54) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 55) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 56) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 57) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 58) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 59) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 60) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 61) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 62) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 63) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 64) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 65) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 66) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 67) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 68) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 69) = 0.000000000000000E+000
- Mak135_V%vs_ak135( 70) = 7.28170000000000
- Mak135_V%vs_ak135( 71) = 7.27000000000000
- Mak135_V%vs_ak135( 72) = 7.25930000000000
- Mak135_V%vs_ak135( 73) = 7.24850000000000
- Mak135_V%vs_ak135( 74) = 7.24850000000000
- Mak135_V%vs_ak135( 75) = 7.22530000000000
- Mak135_V%vs_ak135( 76) = 7.20310000000000
- Mak135_V%vs_ak135( 77) = 7.18040000000000
- Mak135_V%vs_ak135( 78) = 7.15840000000000
- Mak135_V%vs_ak135( 79) = 7.13680000000000
- Mak135_V%vs_ak135( 80) = 7.11440000000000
- Mak135_V%vs_ak135( 81) = 7.09320000000000
- Mak135_V%vs_ak135( 82) = 7.07220000000000
- Mak135_V%vs_ak135( 83) = 7.05040000000000
- Mak135_V%vs_ak135( 84) = 7.02860000000000
- Mak135_V%vs_ak135( 85) = 7.00690000000000
- Mak135_V%vs_ak135( 86) = 6.98520000000000
- Mak135_V%vs_ak135( 87) = 6.96250000000000
- Mak135_V%vs_ak135( 88) = 6.94160000000000
- Mak135_V%vs_ak135( 89) = 6.91940000000000
- Mak135_V%vs_ak135( 90) = 6.89720000000000
- Mak135_V%vs_ak135( 91) = 6.87430000000000
- Mak135_V%vs_ak135( 92) = 6.85170000000000
- Mak135_V%vs_ak135( 93) = 6.82890000000000
- Mak135_V%vs_ak135( 94) = 6.80560000000000
- Mak135_V%vs_ak135( 95) = 6.78200000000000
- Mak135_V%vs_ak135( 96) = 6.75790000000000
- Mak135_V%vs_ak135( 97) = 6.73230000000000
- Mak135_V%vs_ak135( 98) = 6.70700000000000
- Mak135_V%vs_ak135( 99) = 6.68130000000000
- Mak135_V%vs_ak135(100) = 6.65540000000000
- Mak135_V%vs_ak135(101) = 6.62850000000000
- Mak135_V%vs_ak135(102) = 6.60090000000000
- Mak135_V%vs_ak135(103) = 6.57280000000000
- Mak135_V%vs_ak135(104) = 6.54310000000000
- Mak135_V%vs_ak135(105) = 6.51310000000000
- Mak135_V%vs_ak135(106) = 6.48220000000000
- Mak135_V%vs_ak135(107) = 6.45140000000000
- Mak135_V%vs_ak135(108) = 6.41820000000000
- Mak135_V%vs_ak135(109) = 6.38600000000000
- Mak135_V%vs_ak135(110) = 6.35190000000000
- Mak135_V%vs_ak135(111) = 6.31640000000000
- Mak135_V%vs_ak135(112) = 6.27990000000000
- Mak135_V%vs_ak135(113) = 6.24240000000000
- Mak135_V%vs_ak135(114) = 6.21000000000000
- Mak135_V%vs_ak135(115) = 6.08980000000000
- Mak135_V%vs_ak135(116) = 5.96070000000000
- Mak135_V%vs_ak135(117) = 5.61040000000000
- Mak135_V%vs_ak135(118) = 5.50470000000000
- Mak135_V%vs_ak135(119) = 5.39890000000000
- Mak135_V%vs_ak135(120) = 5.29220000000000
- Mak135_V%vs_ak135(121) = 5.18640000000000
- Mak135_V%vs_ak135(122) = 5.08060000000000
- Mak135_V%vs_ak135(123) = 4.87020000000000
- Mak135_V%vs_ak135(124) = 4.78320000000000
- Mak135_V%vs_ak135(125) = 4.69640000000000
- Mak135_V%vs_ak135(126) = 4.60940000000000
- Mak135_V%vs_ak135(127) = 4.51840000000000
- Mak135_V%vs_ak135(128) = 4.51840000000000
- Mak135_V%vs_ak135(129) = 4.50900000000000
- Mak135_V%vs_ak135(130) = 4.50000000000000
- Mak135_V%vs_ak135(131) = 4.49000000000000
- Mak135_V%vs_ak135(132) = 4.48000000000000
- Mak135_V%vs_ak135(133) = 3.85000000000000
- Mak135_V%vs_ak135(134) = 3.85000000000000
- Mak135_V%vs_ak135(135) = 3.46000000000000
- Mak135_V%vs_ak135(136) = 3.46000000000000
-
- 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) = 609.740000000000
- Mak135_V%Qkappa_ak135( 14) = 611.180000000000
- Mak135_V%Qkappa_ak135( 15) = 612.620000000000
- Mak135_V%Qkappa_ak135( 16) = 614.210000000000
- Mak135_V%Qkappa_ak135( 17) = 615.930000000000
- Mak135_V%Qkappa_ak135( 18) = 617.780000000000
- Mak135_V%Qkappa_ak135( 19) = 619.710000000000
- Mak135_V%Qkappa_ak135( 20) = 621.500000000000
- Mak135_V%Qkappa_ak135( 21) = 624.080000000000
- Mak135_V%Qkappa_ak135( 22) = 626.870000000000
- Mak135_V%Qkappa_ak135( 23) = 629.890000000000
- Mak135_V%Qkappa_ak135( 24) = 633.260000000000
- Mak135_V%Qkappa_ak135( 25) = 57822.0000000000
- 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) = 723.120000000000
- Mak135_V%Qkappa_ak135( 71) = 725.110000000000
- Mak135_V%Qkappa_ak135( 72) = 726.870000000000
- Mak135_V%Qkappa_ak135( 73) = 722.730000000000
- Mak135_V%Qkappa_ak135( 74) = 933.210000000000
- Mak135_V%Qkappa_ak135( 75) = 940.880000000000
- Mak135_V%Qkappa_ak135( 76) = 952.000000000000
- Mak135_V%Qkappa_ak135( 77) = 960.360000000000
- Mak135_V%Qkappa_ak135( 78) = 968.460000000000
- Mak135_V%Qkappa_ak135( 79) = 976.810000000000
- Mak135_V%Qkappa_ak135( 80) = 985.630000000000
- Mak135_V%Qkappa_ak135( 81) = 990.770000000000
- Mak135_V%Qkappa_ak135( 82) = 999.440000000000
- Mak135_V%Qkappa_ak135( 83) = 1008.79000000000
- Mak135_V%Qkappa_ak135( 84) = 1018.38000000000
- Mak135_V%Qkappa_ak135( 85) = 1032.14000000000
- Mak135_V%Qkappa_ak135( 86) = 1042.07000000000
- Mak135_V%Qkappa_ak135( 87) = 1048.09000000000
- Mak135_V%Qkappa_ak135( 88) = 1058.03000000000
- Mak135_V%Qkappa_ak135( 89) = 1064.23000000000
- Mak135_V%Qkappa_ak135( 90) = 1070.38000000000
- Mak135_V%Qkappa_ak135( 91) = 1085.97000000000
- Mak135_V%Qkappa_ak135( 92) = 1097.16000000000
- Mak135_V%Qkappa_ak135( 93) = 1108.58000000000
- Mak135_V%Qkappa_ak135( 94) = 1120.09000000000
- Mak135_V%Qkappa_ak135( 95) = 1127.02000000000
- Mak135_V%Qkappa_ak135( 96) = 1134.01000000000
- Mak135_V%Qkappa_ak135( 97) = 1141.32000000000
- Mak135_V%Qkappa_ak135( 98) = 1148.76000000000
- Mak135_V%Qkappa_ak135( 99) = 1156.04000000000
- Mak135_V%Qkappa_ak135(100) = 1163.16000000000
- Mak135_V%Qkappa_ak135(101) = 1170.53000000000
- Mak135_V%Qkappa_ak135(102) = 1178.19000000000
- Mak135_V%Qkappa_ak135(103) = 1186.06000000000
- Mak135_V%Qkappa_ak135(104) = 1193.99000000000
- Mak135_V%Qkappa_ak135(105) = 1202.04000000000
- Mak135_V%Qkappa_ak135(106) = 1210.02000000000
- Mak135_V%Qkappa_ak135(107) = 1217.91000000000
- Mak135_V%Qkappa_ak135(108) = 1226.52000000000
- Mak135_V%Qkappa_ak135(109) = 1234.54000000000
- Mak135_V%Qkappa_ak135(110) = 1243.02000000000
- Mak135_V%Qkappa_ak135(111) = 1251.69000000000
- Mak135_V%Qkappa_ak135(112) = 1260.68000000000
- Mak135_V%Qkappa_ak135(113) = 1269.44000000000
- Mak135_V%Qkappa_ak135(114) = 1277.93000000000
- Mak135_V%Qkappa_ak135(115) = 1311.17000000000
- Mak135_V%Qkappa_ak135(116) = 1350.54000000000
- Mak135_V%Qkappa_ak135(117) = 428.690000000000
- Mak135_V%Qkappa_ak135(118) = 425.510000000000
- Mak135_V%Qkappa_ak135(119) = 422.550000000000
- Mak135_V%Qkappa_ak135(120) = 419.940000000000
- Mak135_V%Qkappa_ak135(121) = 417.320000000000
- Mak135_V%Qkappa_ak135(122) = 413.660000000000
- Mak135_V%Qkappa_ak135(123) = 377.930000000000
- Mak135_V%Qkappa_ak135(124) = 366.340000000000
- Mak135_V%Qkappa_ak135(125) = 355.850000000000
- Mak135_V%Qkappa_ak135(126) = 346.370000000000
- Mak135_V%Qkappa_ak135(127) = 338.470000000000
- Mak135_V%Qkappa_ak135(128) = 200.970000000000
- Mak135_V%Qkappa_ak135(129) = 188.720000000000
- Mak135_V%Qkappa_ak135(130) = 182.570000000000
- Mak135_V%Qkappa_ak135(131) = 182.030000000000
- Mak135_V%Qkappa_ak135(132) = 182.030000000000
- Mak135_V%Qkappa_ak135(133) = 972.770000000000
- Mak135_V%Qkappa_ak135(134) = 972.770000000000
- Mak135_V%Qkappa_ak135(135) = 1368.02000000000
- Mak135_V%Qkappa_ak135(136) = 1368.02000000000
-
- 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) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 26) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 27) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 28) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 29) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 30) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 31) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 32) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 33) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 34) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 35) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 36) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 37) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 38) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 39) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 40) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 41) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 42) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 43) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 44) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 45) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 46) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 47) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 48) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 49) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 50) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 51) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 52) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 53) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 54) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 55) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 56) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 57) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 58) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 59) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 60) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 61) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 62) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 63) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 64) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 65) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 66) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 67) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 68) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 69) = 0.000000000000000E+000
- Mak135_V%Qmu_ak135( 70) = 273.970000000000
- Mak135_V%Qmu_ak135( 71) = 273.970000000000
- Mak135_V%Qmu_ak135( 72) = 273.970000000000
- Mak135_V%Qmu_ak135( 73) = 271.740000000000
- Mak135_V%Qmu_ak135( 74) = 350.880000000000
- Mak135_V%Qmu_ak135( 75) = 354.610000000000
- Mak135_V%Qmu_ak135( 76) = 359.710000000000
- Mak135_V%Qmu_ak135( 77) = 363.640000000000
- Mak135_V%Qmu_ak135( 78) = 367.650000000000
- Mak135_V%Qmu_ak135( 79) = 371.750000000000
- Mak135_V%Qmu_ak135( 80) = 375.940000000000
- Mak135_V%Qmu_ak135( 81) = 378.790000000000
- Mak135_V%Qmu_ak135( 82) = 383.140000000000
- Mak135_V%Qmu_ak135( 83) = 387.600000000000
- Mak135_V%Qmu_ak135( 84) = 392.160000000000
- Mak135_V%Qmu_ak135( 85) = 398.410000000000
- Mak135_V%Qmu_ak135( 86) = 403.230000000000
- Mak135_V%Qmu_ak135( 87) = 406.500000000000
- Mak135_V%Qmu_ak135( 88) = 411.520000000000
- Mak135_V%Qmu_ak135( 89) = 414.940000000000
- Mak135_V%Qmu_ak135( 90) = 418.410000000000
- Mak135_V%Qmu_ak135( 91) = 425.530000000000
- Mak135_V%Qmu_ak135( 92) = 431.030000000000
- Mak135_V%Qmu_ak135( 93) = 436.680000000000
- Mak135_V%Qmu_ak135( 94) = 442.480000000000
- Mak135_V%Qmu_ak135( 95) = 446.430000000000
- Mak135_V%Qmu_ak135( 96) = 450.450000000000
- Mak135_V%Qmu_ak135( 97) = 454.550000000000
- Mak135_V%Qmu_ak135( 98) = 458.720000000000
- Mak135_V%Qmu_ak135( 99) = 462.960000000000
- Mak135_V%Qmu_ak135(100) = 467.290000000000
- Mak135_V%Qmu_ak135(101) = 471.700000000000
- Mak135_V%Qmu_ak135(102) = 476.190000000000
- Mak135_V%Qmu_ak135(103) = 480.770000000000
- Mak135_V%Qmu_ak135(104) = 485.440000000000
- Mak135_V%Qmu_ak135(105) = 490.200000000000
- Mak135_V%Qmu_ak135(106) = 495.050000000000
- Mak135_V%Qmu_ak135(107) = 500.000000000000
- Mak135_V%Qmu_ak135(108) = 505.050000000000
- Mak135_V%Qmu_ak135(109) = 510.200000000000
- Mak135_V%Qmu_ak135(110) = 515.460000000000
- Mak135_V%Qmu_ak135(111) = 520.830000000000
- Mak135_V%Qmu_ak135(112) = 526.320000000000
- Mak135_V%Qmu_ak135(113) = 531.910000000000
- Mak135_V%Qmu_ak135(114) = 537.630000000000
- Mak135_V%Qmu_ak135(115) = 543.480000000000
- Mak135_V%Qmu_ak135(116) = 549.450000000000
- Mak135_V%Qmu_ak135(117) = 172.930000000000
- Mak135_V%Qmu_ak135(118) = 170.820000000000
- Mak135_V%Qmu_ak135(119) = 168.780000000000
- Mak135_V%Qmu_ak135(120) = 166.800000000000
- Mak135_V%Qmu_ak135(121) = 164.870000000000
- Mak135_V%Qmu_ak135(122) = 162.500000000000
- Mak135_V%Qmu_ak135(123) = 146.570000000000
- Mak135_V%Qmu_ak135(124) = 142.760000000000
- Mak135_V%Qmu_ak135(125) = 139.380000000000
- Mak135_V%Qmu_ak135(126) = 136.380000000000
- Mak135_V%Qmu_ak135(127) = 133.720000000000
- Mak135_V%Qmu_ak135(128) = 79.4000000000000
- Mak135_V%Qmu_ak135(129) = 76.5500000000000
- Mak135_V%Qmu_ak135(130) = 76.0600000000000
- Mak135_V%Qmu_ak135(131) = 75.6000000000000
- Mak135_V%Qmu_ak135(132) = 75.6000000000000
- Mak135_V%Qmu_ak135(133) = 403.930000000000
- Mak135_V%Qmu_ak135(134) = 403.930000000000
- Mak135_V%Qmu_ak135(135) = 599.990000000000
- Mak135_V%Qmu_ak135(136) = 599.990000000000
-
-! strip the crust and replace it with mantle
- if (SUPPRESS_CRUSTAL_MESH .or. USE_EXTERNAL_CRUSTAL_MODEL) then
- Mak135_V%vp_ak135(133:136) = Mak135_V%vp_ak135(132)
- Mak135_V%vs_ak135(133:136) = Mak135_V%vs_ak135(132)
- Mak135_V%density_ak135(133:136) = Mak135_V%density_ak135(132)
- Mak135_V%Qkappa_ak135(133:136) = Mak135_V%Qkappa_ak135(132)
- Mak135_V%Qmu_ak135(133:136) = Mak135_V%Qmu_ak135(132)
- endif
-
- end subroutine define_model_ak135
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_inner_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_inner_core.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_inner_core.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-!
-! based on scaling factors by Ishii et al. (2002)
-!
-! one should add an MPI_BCAST in meshfem3D_models.f90 if one
-! adds a 3D model or a read_aniso_inner_core_model subroutine
-!--------------------------------------------------------------------------------------------------
-
- subroutine model_aniso_inner_core(x,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL, &
- vpv,vph,vsv,vsh,rho,eta_aniso)
-
- 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 rho,vpv,vph,vsv,vsh,eta_aniso
-
- ! local parameters
- double precision vp,vs
- double precision vpc,vsc,rhoc
- double precision vp0,vs0,rho0,A0
- double precision c66
- double precision scale_fac
-
- ! calculates isotropic values from given (transversely isotropic) reference values
- ! (are non-dimensionalized)
- 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)
-
- ! scale to dimensions (e.g. used in prem model)
- scale_fac = R_EARTH*dsqrt(PI*GRAV*RHOAV)/1000.d0
- vp = vp * scale_fac
- vs = vs * scale_fac
- rho = rho * RHOAV/1000.d0
-
- select case(REFERENCE_1D_MODEL)
-
- case(REFERENCE_MODEL_IASP91)
- vpc=11.24094d0-4.09689d0*x*x
- vsc=3.56454d0-3.45241d0*x*x
- rhoc=13.0885d0-8.8381d0*x*x
- ! checks with given values
- if( abs(vpc-vp) > TINYVAL .or. abs(vsc-vs) > TINYVAL .or. abs(rhoc-rho) > TINYVAL) then
- stop 'error isotropic IASP91 values in model_aniso_inner_core() '
- endif
-
- ! values at center
- vp0=11.24094d0
- vs0=3.56454d0
- rho0=13.0885d0
-
- case(REFERENCE_MODEL_PREM)
- vpc=11.2622d0-6.3640d0*x*x
- vsc=3.6678d0-4.4475d0*x*x
- rhoc=13.0885d0-8.8381d0*x*x
- ! checks
- if( abs(vpc-vp) > TINYVAL .or. abs(vsc-vs) > TINYVAL .or. abs(rhoc-rho) > TINYVAL) then
- stop 'error isotropic PREM values in model_aniso_inner_core() '
- endif
-
- ! values at center
- vp0=11.2622d0
- vs0=3.6678d0
- rho0=13.0885d0
-
- case(REFERENCE_MODEL_1DREF)
- ! values at center
- vp0 = 11262.20 / 1000.0d0
- vs0 = 3667.800 / 1000.0d0
- rho0 = 13088.480 / 1000.0d0
-
- case(REFERENCE_MODEL_1066A)
- ! values at center
- vp0 = 11.33830
- vs0 = 3.62980
- rho0 = 13.429030
-
- case(REFERENCE_MODEL_AK135)
- ! values at center
- vp0 = 11.26220
- vs0 = 3.667800
- rho0 = 13.01220
-
- case(REFERENCE_MODEL_JP1D)
- ! values at center
- vp0 = 11.24094
- vs0 = 3.56454
- rho0 = 13.0885d0
-
- case(REFERENCE_MODEL_SEA1D)
- ! values at center
- vp0 = 11.240940
- vs0 = 3.564540
- rho0 = 13.012190
-
- case default
- stop 'unknown 1D reference Earth model in anisotropic inner core'
-
- end select
-
-! non-dimensionalization of elastic parameters (GPa--[g/cm^3][(km/s)^2])
- scale_fac = RHOAV*R_EARTH*R_EARTH*PI*GRAV*RHOAV
- scale_fac = 1.d9 / scale_fac
-
-! 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
-
-! 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
-! and c12 = c11 - 2*c66
-!
-! 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*scale_fac
- c66 = rho*vs*vs*scale_fac
- c12 = c11 - 2.0d0*c66
-
- A0 = rho0*vp0*vp0*scale_fac
-
- c33 = c11 + 0.0349d0*A0
- c44 = c66 + 0.00988d0*A0
- c13 = c12 - 0.00881d0*A0
-
- end subroutine model_aniso_inner_core
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_mantle.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_mantle.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,907 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-!
-! 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 model_aniso_mantle_broadcast(myrank,AMM_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
- ! model_aniso_mantle_variables
- type model_aniso_mantle_variables
- sequence
- double precision beta(14,34,37,73)
- double precision pro(47)
- integer npar1
- integer dummy_pad ! padding 4 bytes to align the structure
- end type model_aniso_mantle_variables
-
- type (model_aniso_mantle_variables) AMM_V
- ! model_aniso_mantle_variables
-
- integer :: myrank
- integer :: ier
-
- ! 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)
-
-
- end subroutine model_aniso_mantle_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine model_aniso_mantle(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"
-
-! model_aniso_mantle_variables
- type model_aniso_mantle_variables
- sequence
- double precision beta(14,34,37,73)
- double precision pro(47)
- integer npar1
- integer dummy_pad ! padding 4 bytes to align the structure
- end type model_aniso_mantle_variables
-
- type (model_aniso_mantle_variables) AMM_V
-! model_aniso_mantle_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 model_aniso_mantle
-
-!--------------------------------------------------------------------
-
- 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"
-
-! model_aniso_mantle_variables
- type model_aniso_mantle_variables
- sequence
- double precision beta(14,34,37,73)
- double precision pro(47)
- integer npar1
- integer dummy_pad ! padding 4 bytes to align the structure
- end type model_aniso_mantle_variables
-
- type (model_aniso_mantle_variables) AMM_V
-! model_aniso_mantle_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/model_atten3D_QRFSI12.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_atten3D_QRFSI12.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_atten3D_QRFSI12.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,736 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-!
-! This file contains subroutines to read in and get values for
-! 3-D attenuation model QRFSI12 (Dalton, Ekstrom, & Dziewonski, 2008)
-!
-! C.A. Dalton, G. Ekstr\"om and A.M. Dziewonski, 2008.
-! The global attenuation structure of the upper mantle,
-! J. Geophys. Res., 113, B05317,10.1029/2006JB004394
-!
-! Last edit: Colleen Dalton, March 25, 2008
-!
-! Q1: what are theta and phi?
-! Q2: units for radius?
-! Q3: what to do about core?
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_atten3D_QRFSI12_broadcast(myrank,QRFSI12_Q)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
- ! model_atten3D_QRFSI12_variables
- type model_atten3D_QRFSI12_variables
- sequence
- double precision dqmu(NKQ,NSQ)
- double precision spknt(NKQ)
- double precision refdepth(NDEPTHS_REFQ)
- double precision refqmu(NDEPTHS_REFQ)
- end type model_atten3D_QRFSI12_variables
-
- type (model_atten3D_QRFSI12_variables) QRFSI12_Q
- ! model_atten3D_QRFSI12_variables
-
- integer :: myrank
- integer :: ier
-
- if(myrank == 0) call read_atten_model_3D_QRFSI12(QRFSI12_Q)
-
- call MPI_BCAST(QRFSI12_Q%dqmu, NKQ*NSQ,MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
- call MPI_BCAST(QRFSI12_Q%spknt, NKQ,MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
- call MPI_BCAST(QRFSI12_Q%refdepth, NDEPTHS_REFQ,MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
- call MPI_BCAST(QRFSI12_Q%refqmu, NDEPTHS_REFQ,MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
-
- if(myrank == 0) write(IMAIN,*) 'read 3D attenuation model'
-
-
- end subroutine
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_atten_model_3D_QRFSI12(QRFSI12_Q)
-
- implicit none
-
- include "constants.h"
-
-! three_d_model_atten3D_QRFSI12_variables
- type model_atten3D_QRFSI12_variables
- sequence
- double precision dqmu(NKQ,NSQ)
- double precision spknt(NKQ)
- double precision refdepth(NDEPTHS_REFQ)
- double precision refqmu(NDEPTHS_REFQ)
- end type model_atten3D_QRFSI12_variables
-
- type (model_atten3D_QRFSI12_variables) QRFSI12_Q
-! three_d_model_atten3D_QRFSI12_variables
-
- integer j,k,l,m
- integer index,ll,mm
- double precision v1,v2
-
- character(len=150) QRFSI12,QRFSI12_ref
-
-! read in QRFSI12
-! hard-wire for now
- QRFSI12='DATA/QRFSI12/QRFSI12.dat'
- QRFSI12_ref='DATA/QRFSI12/ref_QRFSI12'
-
-! get the dq model coefficients
- open(unit=10,file=QRFSI12,status='old',action='read')
- do k=1,NKQ
- read(10,*)index
- j=0
- do l=0,MAXL_Q
- do m=0,l
- if(m.eq.0)then
- j=j+1
- read(10,*)ll,mm,v1
- QRFSI12_Q%dqmu(k,j)=v1
- else
- j=j+2
- read(10,*)ll,mm,v1,v2
- ! write(*,*) 'k,l,m,ll,mm:',k,l,m,ll,mm,v1
- QRFSI12_Q%dqmu(k,j-1)=2.*v1
- QRFSI12_Q%dqmu(k,j)=-2.*v2
- endif
- enddo
- enddo
- enddo
- close(10)
-
-! get the depths (km) of the spline knots
- QRFSI12_Q%spknt(1) = 24.4
- QRFSI12_Q%spknt(2) = 75.0
- QRFSI12_Q%spknt(3) = 150.0
- QRFSI12_Q%spknt(4) = 225.0
- QRFSI12_Q%spknt(5) = 300.0
- QRFSI12_Q%spknt(6) = 410.0
- QRFSI12_Q%spknt(7) = 530.0
- QRFSI12_Q%spknt(8) = 650.0
-
-! get the depths and 1/Q values of the reference model
- open(11,file=QRFSI12_ref,status='old',action='read')
- do j=1,NDEPTHS_REFQ
- read(11,*)QRFSI12_Q%refdepth(j),QRFSI12_Q%refqmu(j)
- enddo
- close(11)
-
-
- end subroutine read_atten_model_3D_QRFSI12
-
-!----------------------------------
-!----------------------------------
-
- subroutine model_atten3D_QRFSI12(radius,theta,phi,Qmu,QRFSI12_Q,idoubling)
-
- implicit none
-
- include "constants.h"
-
-! model_atten3D_QRFSI12_variables
- type model_atten3D_QRFSI12_variables
- sequence
- double precision dqmu(NKQ,NSQ)
- double precision spknt(NKQ)
- double precision refdepth(NDEPTHS_REFQ)
- double precision refqmu(NDEPTHS_REFQ)
- end type model_atten3D_QRFSI12_variables
-
- type (model_atten3D_QRFSI12_variables) QRFSI12_Q
-! model_atten3D_QRFSI12_variables
-
- integer i,j,k,n,idoubling
- integer ifnd
- double precision radius,theta,phi,Qmu,smallq,dqmu,smallq_ref
- real(kind=4) splpts(NKQ),splcon(NKQ),splcond(NKQ)
- real(kind=4) depth,ylat,xlon
- real(kind=4) shdep(NSQ)
- real(kind=4) xlmvec(NSQ),wk1(NSQ),wk2(NSQ),wk3(NSQ)
- double precision, parameter :: rmoho_prem = 6371.0-24.4
- double precision, parameter :: rcmb = 3480.0
-
- !in Colleen's original code theta refers to the latitude. Here we have redefined theta to be colatitude
- !to agree with the rest of specfem
-! print *,'entering QRFSI12 subroutine'
-
- ylat=90.0d0-theta
- xlon=phi
-
-! only checks radius for crust, idoubling is missleading for oceanic crust when we want to expand mantle up to surface...
-! !if(idoubling == IFLAG_CRUST .or. radius >= rmoho) then
- if( radius >= rmoho_prem ) then
- ! print *,'QRFSI12: we are in the crust'
- Qmu = 600.0d0
- else if(idoubling == IFLAG_INNER_CORE_NORMAL .or. idoubling == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- idoubling == IFLAG_BOTTOM_CENTRAL_CUBE .or. idoubling == IFLAG_TOP_CENTRAL_CUBE .or. &
- idoubling == IFLAG_IN_FICTITIOUS_CUBE) then
- ! print *,'QRFSI12: we are in the inner core'
- Qmu = 84.6d0
- else if(idoubling == IFLAG_OUTER_CORE_NORMAL) then
- ! print *,'QRFSI12: we are in the outer core'
- Qmu = 0.0d0
- else !we are in the mantle
- depth = 6371.-radius
-! print *,'QRFSI12: we are in the mantle at depth',depth
- ifnd=0
- do i=2,NDEPTHS_REFQ
- if(depth >= QRFSI12_Q%refdepth(i-1) .and. depth < QRFSI12_Q%refdepth(i))then
- ifnd=i
- endif
- enddo
- if(ifnd == 0)then
- write(6,"('problem finding reference Q value at depth: ',f8.3)") depth
- stop
- endif
- smallq_ref=QRFSI12_Q%refqmu(ifnd)
- smallq = smallq_ref
-
- if(depth < 650.d0) then !Colleen's model is only defined between depths of 24.4 and 650km
- do j=1,NSQ
- shdep(j)=0.
- enddo
- do n=1,NKQ
- splpts(n)=QRFSI12_Q%spknt(n)
- enddo
- call vbspl(depth,NKQ,splpts,splcon,splcond)
- do n=1,NKQ
- do j=1,NSQ
- shdep(j)=shdep(j)+(splcon(n)*QRFSI12_Q%dqmu(n,j))
- enddo
- enddo
- call ylm(ylat,xlon,MAXL_Q,xlmvec,wk1,wk2,wk3)
- dqmu=0.
- do k=1,NSQ
- dqmu=dqmu+xlmvec(k)*shdep(k)
- enddo
- smallq = smallq_ref + dqmu
- endif
- ! if smallq is small and negative (due to numerical error), Qmu is very large:
- if(smallq < 0.0d0) smallq = 1.0d0/ATTENUATION_COMP_MAXIMUM
- Qmu = 1/smallq
- ! Qmu is larger than MAX_ATTENUATION_VALUE, set it to ATTENUATION_COMP_MAXIMUM. This assumes that this
- ! value is high enough that at this point there is almost no attenuation at all.
- if(Qmu >= ATTENUATION_COMP_MAXIMUM) Qmu = 0.99d0*ATTENUATION_COMP_MAXIMUM
-
- endif
-
- end subroutine model_atten3D_QRFSI12
-
-!----------------------------------
-!----------------------------------
-
-!!$ 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
-!!$
-!!$ integer :: L,M,i,k,LP1,MP1
-!!$ real(kind=4) :: THETA,X,XP,XCOSEC,SFL3
-!!$
-!!$ DIMENSION X(2),XP(2),XCOSEC(2)
-!!$ DOUBLE PRECISION SMALL,SUM,COMPAR,CT,ST,FCT,COT,FPI,X1,X2,X3,F1,F2,XM,TH,DSFL3,COSEC
-!!$ DATA FPI/12.56637062D0/
-!!$! DFLOAT(I)=FLOAT(I)
-!!$ SUM=0.D0
-!!$ LP1=L+1
-!!$ TH=THETA
-!!$ CT=DCOS(TH)
-!!$ ST=DSIN(TH)
-!!$ MP1=M+1
-!!$ FCT=DSQRT(dble(FLOAT(2*L+1))/FPI)
-!!$ SFL3=SQRT(FLOAT(L*(L+1)))
-!!$ COMPAR=dble(FLOAT(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.GT.1.AND.ABS(THETA).GT.1.E-5) GO TO 3
-!!$ X(1)=FCT
-!!$ IF(L.EQ.0) RETURN
-!!$ X(1)=CT*FCT
-!!$ X(2)=-ST*FCT/DSFL3
-!!$ XP(1)=-ST*FCT
-!!$ XP(2)=-.5D0*CT*FCT*DSFL3
-!!$ IF(ABS(THETA).LT.1.E-5) XCOSEC(2)=XP(2)
-!!$ IF(ABS(THETA).GE.1.E-5) XCOSEC(2)=X(2)/ST
-!!$ RETURN
-!!$ 3 X1=1.D0
-!!$ X2=CT
-!!$ DO I=2,L
-!!$ X3=(dble(FLOAT(2*I-1))*CT*X2-dble(FLOAT(I-1))*X1)/dble(FLOAT(I))
-!!$ X1=X2
-!!$ X2=X3
-!!$ enddo
-!!$ COT=CT/ST
-!!$ COSEC=1./ST
-!!$ X3=X2*FCT
-!!$ X2=dble(FLOAT(L))*(X1-CT*X2)*FCT/ST
-!!$ X(1)=X3
-!!$ X(2)=X2
-!!$ SUM=X3*X3
-!!$ XP(1)=-X2
-!!$ XP(2)=dble(FLOAT(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.GT.SMALL) RETURN
-!!$ X1=X3
-!!$ X2=-X2/DSQRT(dble(FLOAT(L*(L+1))))
-!!$ DO I=3,MP1
-!!$ K=I-1
-!!$ F1=DSQRT(dble(FLOAT((L+I-1)*(L-I+2))))
-!!$ F2=DSQRT(dble(FLOAT((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.GT.SMALL.AND.I.NE.LP1) RETURN
-!!$ X(I)=X3
-!!$ XCOSEC(I)=X(I)*COSEC
-!!$ X1=X2
-!!$ XP(I)=-(F1*X2+XM*COT*X3)
-!!$ X2=X3
-!!$ enddo
-!!$ RETURN
-!!$ end subroutine legndr
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_attenuation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_attenuation.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_attenuation.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1485 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-!
-! 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 model_attenuation_broadcast(myrank,AM_V,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
-! model_attenuation_variables
- type model_attenuation_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
- 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, dimension(:), pointer :: interval_Q ! Steps
- integer :: Qn ! Number of points
- integer dummy_pad ! padding 4 bytes to align the structure
- end type model_attenuation_variables
-
- type (model_attenuation_variables) AM_V
-! model_attenuation_variables
-
- integer :: MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
- integer :: myrank
- integer :: ier
-
- if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V)
-
- if(myrank /= 0) allocate(AM_V%Qtau_s(N_SLS))
- 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)
-
-
- end subroutine
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_attenuation_model(min_att_period, max_att_period, AM_V)
-
- implicit none
-
- include 'constants.h'
-
-! model_attenuation_variables
- type model_attenuation_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
- 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, dimension(:), pointer :: interval_Q ! Steps
- integer :: Qn ! Number of points
- integer dummy_pad ! padding 4 bytes to align the structure
- end type model_attenuation_variables
-
- type (model_attenuation_variables) AM_V
-! model_attenuation_variables
-
- integer min_att_period, max_att_period
-
- AM_V%min_period = min_att_period * 1.0d0
- AM_V%max_period = max_att_period * 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
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-! 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 model_attenuation_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'
-
-! model_attenuation_variables
- type model_attenuation_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
- 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, dimension(:), pointer :: interval_Q ! Steps
- integer :: Qn ! Number of points
- integer dummy_pad ! padding 4 bytes to align the structure
- end type model_attenuation_variables
-
- type (model_attenuation_variables) AM_V
-! model_attenuation_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_1dref_variables
- type model_1dref_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_1dref_variables
-
- type (model_1dref_variables) Mref_V
-! model_1dref_variables
-
-! model_sea1d_variables
- type model_sea1d_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 model_sea1d_variables
-
- type (model_sea1d_variables) SEA1DM_V
-! model_sea1d_variables
-
-! model_attenuation_storage_var
- type model_attenuation_storage_var
- sequence
- double precision, dimension(:,:), pointer :: tau_e_storage
- double precision, dimension(:), pointer :: Qmu_storage
- integer Q_resolution
- integer Q_max
- end type model_attenuation_storage_var
-
- type (model_attenuation_storage_var) AM_S
-! model_attenuation_storage_var
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- 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
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = 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 ! as defined by IASP91
-
- call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
- if(myrank > 0) return
-
-
- ! uses "pure" 1D models including their 1D-crust profiles
- ! (uses USE_EXTERNAL_CRUSTAL_MODEL set to false)
- 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_1DREF) then
- call define_model_1dref(.FALSE.,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
-
- ! sets up attenuation storage (for all possible Qmu values defined in the 1D models)
- 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_1DREF) 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 model_attenuation_getstored_tau(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 model_attenuation_setup
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine model_attenuation_getstored_tau(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'
-
-! model_attenuation_variables
- type model_attenuation_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
- 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, dimension(:), pointer :: interval_Q ! Steps
- integer :: Qn ! Number of points
- integer dummy_pad ! padding 4 bytes to align the structure
- end type model_attenuation_variables
-
- type (model_attenuation_variables) AM_V
-! model_attenuation_variables
-
-! model_attenuation_storage_var
- type model_attenuation_storage_var
- sequence
- double precision, dimension(:,:), pointer :: tau_e_storage
- double precision, dimension(:), pointer :: Qmu_storage
- integer Q_resolution
- integer Q_max
- end type model_attenuation_storage_var
-
- type (model_attenuation_storage_var) AM_S
-! model_attenuation_storage_var
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- 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
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = 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 model_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 model_attenuation_storage(Qmu_in, tau_e, rw, AM_S)
-
- end subroutine model_attenuation_getstored_tau
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine model_attenuation_storage(Qmu, tau_e, rw, AM_S)
-
- implicit none
- include 'mpif.h'
- include 'constants.h'
-
-! model_attenuation_storage_var
- type model_attenuation_storage_var
- sequence
- double precision, dimension(:,:), pointer :: tau_e_storage
- double precision, dimension(:), pointer :: Qmu_storage
- integer Q_resolution
- integer Q_max
- end type model_attenuation_storage_var
-
- type (model_attenuation_storage_var) AM_S
-! model_attenuation_storage_var
-
- 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 attenuation_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;
-
- ! by default: resolution is Q_resolution = 10
- ! converts Qmu to an array integer index:
- ! e.g. Qmu = 150.31 -> Qtmp = 150.31 * 10 = int( 1503.10 ) = 1503
- Qtmp = Qmu * dble(AM_S%Q_resolution)
-
- ! rounds to corresponding double value:
- ! e.g. Qmu_new = dble( 1503 ) / dble(10) = 150.30
- ! but Qmu_new is not used any further...
- 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 model_attenuation_storage
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- 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
- 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
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = 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
- 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
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = 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
- 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
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = 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
- 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
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = 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
- 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
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = 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_local(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_local(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_local(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_local
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-! unused routines...
-!
-!
-! subroutine model_attenuation_1D_PREM(x, Qmu)
-!
-!! x is 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
-!
-!! Since R80 may be changed, we use radius to decide the attenuation region
-!! rather than doubling flag
-!
-! ! 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 model_attenuation_1D_PREM
-!
-!!
-!!-------------------------------------------------------------------------------------------------
-!!
-!
-!! get 1D REF attenuation model according to radius
-! subroutine model_attenuation_1D_REF(x, Qmu)
-!
-!! x in the radius from 0 to 1 where 0 is the center and 1 is the surface
-!! This version is for 1D REF.
-!
-! implicit none
-!
-! include 'constants.h'
-!
-! 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 = 5961000.d0
-! R600 = 5771000.d0
-! R670 = 5721000.d0
-! R771 = 5600000.d0
-! RTOPDDOUBLEPRIME = 3630000.d0
-! RCMB = 3479958.d0
-! RICB = 1221491.d0
-!
-!! REF model
-!!
-!!--- inner core
-!!
-! if(r >= 0.d0 .and. r <= RICB) then
-! Qmu=104.0d0
-! Qkappa=1327.6d0
-!
-!!--- outer core
-!!
-! else if(r > RICB .and. r <= RCMB) then
-! Qmu=0.0d0
-! Qkappa=57822.5d0
-! if(RCMB - r < r - RICB) then
-! Qmu = 355.0d0 ! CMB
-! else
-! Qmu = 104.0d0 ! ICB
-! endif
-!
-!!--- D" at the base of the mantle
-!!
-! else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
-! Qmu=355.0d0
-! Qkappa=57822.5d0
-!
-!!--- mantle: from top of D" to d670
-!!
-! else if(r > RTOPDDOUBLEPRIME .and. r <= R670) then
-! Qmu=355.0d0
-! Qkappa=57822.5d0
-!
-!!--- mantle: above d670
-!!
-! else if(r > R670 .and. r <= R220) then
-! Qmu=165.0d0
-! Qkappa=943.0d0
-! else if(r > R220 .and. r <= R80) then
-! Qmu=70.0d0
-! Qkappa=943.0d0
-! else if(r > R80.and. r<=RMOHO) then
-! Qmu=191.0d0
-! Qkappa=943.0d0
-! else if (r > RMOHO) then
-! Qmu=300.0d0
-! Qkappa=57822.5d0
-! endif
-!
-! end subroutine model_attenuation_1D_REF
-!
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_crust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_crust.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_crust.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! CRUST 2.0 model by Bassin et al. (2000)
-!
-! C. Bassin, G. Laske, and G. Masters.
-! The current limits of resolution for surface wave tomography in North America.
-! EOS, 81: F897, 2000.
-!
-! reads and smooths crust2.0 model
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_crust_broadcast(myrank,CM_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
- ! model_crust_variables
- type model_crust_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)
- character(len=2) dummy_pad ! padding 2 bytes to align the structure
- end type model_crust_variables
-
- type (model_crust_variables) CM_V
- ! model_crust_variables
-
- integer :: myrank
- integer :: ier
-
- ! the variables read are declared and stored in structure CM_V
- if(myrank == 0) call read_crust_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)
-
-
- end subroutine model_crust_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine model_crust(lat,lon,x,vp,vs,rho,moho,found_crust,CM_V,elem_in_crust)
-
- implicit none
- include "constants.h"
-
-! model_crust_variables
- type model_crust_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)
- character(len=2) dummy_pad ! padding 2 bytes to align the structure
- end type model_crust_variables
-
- type (model_crust_variables) CM_V
-! model_crust_variables
-
- double precision lat,lon,x,vp,vs,rho,moho
- logical found_crust,elem_in_crust
-
- ! local parameters
- 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)
-
- ! initializes
- vp = 0.d0
- vs = 0.d0
- rho = 0.d0
-
- ! gets smoothed crust2.0 structure
- call crust_CAPsmoothed(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 &
-! .and. h_sed >= MINIMUM_SEDIMENT_THICKNESS) then
- 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 &
-! .and. h_sed >= MINIMUM_SEDIMENT_THICKNESS) then
- 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 .or. elem_in_crust) then
- ! takes lower crustal values only if x is slightly above moho depth or
- ! if elem_in_crust is set
- !
- ! note: it looks like this does distinguish between GLL points at the exact moho boundary,
- ! where the point is on the interface between both,
- ! oceanic elements and mantle elements below
- vp = vps(7)
- vs = vss(7)
- rho = rhos(7)
- else
- ! note: if x is exactly the moho depth this will return false
- found_crust = .false.
- endif
-
- ! non-dimensionalize
- if (found_crust) then
- scaleval = dsqrt(PI*GRAV*RHOAV)
- vp = vp*1000.0d0/(R_EARTH*scaleval)
- vs = vs*1000.0d0/(R_EARTH*scaleval)
- rho = rho*1000.0d0/RHOAV
- endif
-
- ! checks moho value
- !moho = h_uc + thicks(6) + thicks(7)
- !if( moho /= thicks(NLAYERS_CRUST) ) then
- ! print*,'moho:',moho,thicks(NLAYERS_CRUST)
- ! print*,' lat/lon/x:',lat,lon,x
- !endif
-
- ! No matter found_crust true or false, output moho thickness
- moho = (h_uc+thicks(6)+thicks(7))*1000.0d0/R_EARTH
-
- end subroutine model_crust
-
-!---------------------------
-
- subroutine read_crust_model(CM_V)
-
- implicit none
- include "constants.h"
-
-! model_crust_variables
- type model_crust_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)
- character(len=2) dummy_pad ! padding 2 bytes to align the structure
- end type model_crust_variables
-
- type (model_crust_variables) CM_V
-! model_crust_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_crust_model'
-
- end subroutine read_crust_model
-
-!---------------------------
-
- subroutine crust_CAPsmoothed(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"
-
- ! sampling rate for CAP points
- integer, parameter :: NTHETA = 4
- integer, parameter :: NPHI = 20
-
- ! 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)
-
- !-------------------------------
- ! work-around to avoid jacobian problems when stretching mesh elements;
- ! one could also try to slightly change the shape of the doulbing element bricks (which cause the problem)...
- !
- ! defines a "critical" region around the andes to have at least a 2-degree smoothing;
- ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
- double precision,parameter :: LAT_CRITICAL_ANDES = -20.0d0
- double precision,parameter :: LON_CRITICAL_ANDES = -70.0d0
- double precision,parameter :: CRITICAL_RANGE = 70.0d0
- !-------------------------------
-
- ! local variables
- 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)
- double precision weightl,cap_degree,dist
- double precision h_sed
- integer i,icolat,ilon,ierr
- character(len=2) crustaltype
-
- ! checks latitude/longitude
- if(lat > 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) &
- stop 'error in latitude/longitude range in crust'
-
- ! makes sure lat/lon are within crust2.0 range
- 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
-
- ! sets up smoothing points
- ! by default uses CAP smoothing with 1 degree
- cap_degree = 1.0d0
-
- ! checks if inside/outside of critical region for mesh stretching
- if( SMOOTH_CRUST ) then
- dist = dsqrt( (lon-LON_CRITICAL_ANDES)**2 + (lat-LAT_CRITICAL_ANDES )**2 )
- if( dist < CRITICAL_RANGE ) then
- ! increases cap smoothing degree
- ! scales between -1 at center and 0 at border
- dist = dist / CRITICAL_RANGE - 1.0d0
- ! shifts value to 1 at center and 0 to the border with exponential decay
- dist = 1.0d0 - exp( - dist*dist*10.0d0 )
- ! increases smoothing degree inside of critical region to 2 degree
- cap_degree = cap_degree + dist
- endif
- endif
-
- ! gets smoothing points and weights
- call CAP_vardegree(lon,lat,xlon,xlat,weight,cap_degree,NTHETA,NPHI)
-
- ! initializes
- velp(:) = 0.0d0
- vels(:) = 0.0d0
- rho(:) = 0.0d0
- thick(:) = 0.0d0
-
- ! loops over weight points
- do i=1,NTHETA*NPHI
- ! gets crust values
- 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'
-
- ! sediment thickness
- h_sed = thickl(3) + thickl(4)
-
- ! takes upper crust value if sediment too thin
- if( h_sed < MINIMUM_SEDIMENT_THICKNESS ) then
- velpl(3) = velpl(5)
- velpl(4) = velpl(5)
- velsl(3) = velsl(5)
- velsl(4) = velsl(5)
- rhol(3) = rhol(5)
- rhol(4) = rhol(5)
- endif
-
- ! weighting value
- weightl = weight(i)
-
- ! total, smoothed values
- rho(:) = rho(:) + weightl*rhol(:)
- thick(:) = thick(:) + weightl*thickl(:)
- velp(:) = velp(:) + weightl*velpl(:)
- vels(:) = vels(:) + weightl*velsl(:)
- enddo
-
- end subroutine crust_CAPsmoothed
-
-
-!------------------------------------------------------
-
- 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
-
-
-!---------------------------
-
- subroutine CAP_vardegree(lon,lat,xlon,xlat,weight,CAP_DEGREE,NTHETA,NPHI)
-
-! calculates weighting points to smooth around lon/lat location with
-! a smoothing range of CAP_DEGREE
-!
-! The cap is rotated to the North Pole.
-!
-! returns: xlon,xlat,weight
-
- implicit none
- include "constants.h"
-
- ! sampling rate
- integer :: NTHETA
- integer :: NPHI
- ! smoothing size (in degrees)
- double precision :: CAP_DEGREE
-
- ! argument variables
- double precision lat,lon
- double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
-
- ! local variables
- double precision CAP
- double precision theta,phi,sint,cost,sinp,cosp,wght,total
- double precision r_rot,theta_rot,phi_rot
- double precision rotation_matrix(3,3),x(3),xc(3)
- double precision dtheta,dphi,cap_area,dweight,pi_over_nphi
- integer i,j,k
- integer itheta,iphi
-
- double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
- double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
-
- ! initializes
- xlon(:) = 0.d0
- xlat(:) = 0.d0
- weight(:) = 0.d0
-
- ! checks cap degree size
- if( CAP_DEGREE < TINYVAL ) then
- ! no cap smoothing
- print*,'error cap:',CAP_DEGREE
- print*,' lat/lon:',lat,lon
- stop 'error cap_degree too small'
- endif
-
- ! pre-compute parameters
- CAP = CAP_DEGREE * PI/180.0d0
- dtheta = 0.5d0 * CAP / dble(NTHETA)
- dphi = TWO_PI / dble(NPHI)
- cap_area = TWO_PI * (1.0d0 - dcos(CAP))
- dweight = CAP / dble(NTHETA) * dphi / cap_area
- pi_over_nphi = PI/dble(NPHI)
-
- ! colatitude/longitude in radian
- theta = (90.0d0 - lat ) * DEGREES_TO_RADIANS
- phi = lon * DEGREES_TO_RADIANS
-
- sint = dsin(theta)
- cost = dcos(theta)
- sinp = dsin(phi)
- cosp = dcos(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.0d0
- rotation_matrix(3,3) = cost
-
- ! calculates points over a cap at the North pole and rotates them to specified lat/lon point
- i = 0
- total = 0.0d0
- do itheta = 1,NTHETA
-
- theta = dble(2*itheta-1)*dtheta
- cost = dcos(theta)
- sint = dsin(theta)
- wght = sint*dweight
-
- 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_over_nphi
- cosp = dcos(phi)
- sinp = dsin(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.0d0
- 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_OVER_TWO - theta_rot) * RADIANS_TO_DEGREES
- xlon(i) = phi_rot * RADIANS_TO_DEGREES
- if(xlon(i) > 180.0d0) xlon(i) = xlon(i) - 360.0d0
-
- enddo
-
- enddo
- if(abs(total-1.0d0) > 0.001d0) then
- print*,'error cap:',total,CAP_DEGREE
- stop 'error in cap integration for variable degree'
- endif
-
- end subroutine
-
-
-!---------------------------
-! unused routines...
-!
-! subroutine crust_singlevalue(lat,lon,velp,vels,rho,thick,abbreviation,&
-! code,thlr,velocp,velocs,dens)
-!
-!! crustal vp and vs in km/s, layer thickness in km
-!
-!! uses crust2.0 as is, without smoothing
-!
-! implicit none
-! include "constants.h"
-!
-!! 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 icolat,ilon,ierr
-! 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)
-! if( ierr /= 0 ) stop 'error in routine get_crust_structure'
-!
-! end subroutine crust_singlevalue
-!
-!---------------------------
-!
-!
-! subroutine crust_org(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"
-!! Change the CAP function to smooth crustal model
-! integer, parameter :: NTHETA = 4 !2
-! integer, parameter :: NPHI = 20 !10
-! double precision, parameter :: CAP = 1.0d0*PI/180.0d0 ! 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_org
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_crustmaps.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_crustmaps.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_crustmaps.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,757 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! General Crustmaps
-!
-! combines Crust2.0 and EUcrust07 for moho depths; the crustal maps are
-! interpolating the crustal velocities from Crust2.0 onto the more detailed EUcrust
-! crustal depths where ever they are defined.
-
-! current crustmaps (cmaps) take sediment thickness
-! and moho depths from EUcrust07 if possible and interpolate corresponding
-! velocity/densities given from Crust2.0.
-!
-! main author: Matthias Meschede (meschede at princeton.edu)
-!--------------------------------------------------------------------------------------------------
-
- subroutine model_crustmaps_broadcast(myrank,GC_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
- integer :: myrank
-
- !model_crustmaps_variables
- type model_crustmaps_variables
- sequence
- double precision, dimension(180*CRUSTMAP_RESOLUTION,&
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
-
- double precision thicknessnp(NLAYERS_CRUSTMAP)
- double precision densitynp(NLAYERS_CRUSTMAP)
- double precision velocpnp(NLAYERS_CRUSTMAP)
- double precision velocsnp(NLAYERS_CRUSTMAP)
- double precision thicknesssp(NLAYERS_CRUSTMAP)
- double precision densitysp(NLAYERS_CRUSTMAP)
- double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
-
- end type model_crustmaps_variables
- type (model_crustmaps_variables) GC_V
- !model_crustmaps_variables
-
- ! local parameters
- integer :: ier
-
- ! master reads in crust maps
- if(myrank == 0) &
- call read_general_crustmap(GC_V)
-
- ! broadcasts values to all processes
- call MPI_BCAST(GC_V%thickness,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocp,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocs,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%density,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- ! north pole
- call MPI_BCAST(GC_V%thicknessnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%densitynp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocpnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocsnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%densitynp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- ! south pole
- call MPI_BCAST(GC_V%thicknesssp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%densitysp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocpsp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocssp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%densitysp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
-
- end subroutine model_crustmaps_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-! read general crustmap by Matthias Meschede
-
- subroutine read_general_crustmap(GC_V)
-
- implicit none
- include "constants.h"
-
-!Matthias Meschede
- !model_crustmaps_variables
- type model_crustmaps_variables
- sequence
- double precision, dimension(180*CRUSTMAP_RESOLUTION,&
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
-
- double precision thicknessnp(NLAYERS_CRUSTMAP)
- double precision densitynp(NLAYERS_CRUSTMAP)
- double precision velocpnp(NLAYERS_CRUSTMAP)
- double precision velocsnp(NLAYERS_CRUSTMAP)
- double precision thicknesssp(NLAYERS_CRUSTMAP)
- double precision densitysp(NLAYERS_CRUSTMAP)
- double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
-
- end type model_crustmaps_variables
- type (model_crustmaps_variables) GC_V
- !model_crustmaps_variables
-
-
-
- integer ila,iln,i,l
-
- character(len=150) eucrustt3,eucrustt4,eucrustt5,eucrustt6,eucrustt7,&
- eucrustr3,eucrustr4,eucrustr5,eucrustr6,eucrustr7,&
- eucrustp3,eucrustp4,eucrustp5,eucrustp6,eucrustp7,&
- eucrusts3,eucrusts4,eucrusts5,eucrusts6,eucrusts7
-
-!Matthias Meschede
- call get_value_string(eucrustt3, 'model.eucrustt3','DATA/crustmap/eucrustt3.cmap')
- call get_value_string(eucrustt4, 'model.eucrustt4','DATA/crustmap/eucrustt4.cmap')
- call get_value_string(eucrustt5, 'model.eucrustt5','DATA/crustmap/eucrustt5.cmap')
- call get_value_string(eucrustt6, 'model.eucrustt6','DATA/crustmap/eucrustt6.cmap')
- call get_value_string(eucrustt7, 'model.eucrustt7','DATA/crustmap/eucrustt7.cmap')
-
- call get_value_string(eucrustr3, 'model.eucrustr3','DATA/crustmap/eucrustr3.cmap')
- call get_value_string(eucrustr4, 'model.eucrustr4','DATA/crustmap/eucrustr4.cmap')
- call get_value_string(eucrustr5, 'model.eucrustr5','DATA/crustmap/eucrustr5.cmap')
- call get_value_string(eucrustr6, 'model.eucrustr6','DATA/crustmap/eucrustr6.cmap')
- call get_value_string(eucrustr7, 'model.eucrustr7','DATA/crustmap/eucrustr7.cmap')
-
- call get_value_string(eucrustp3, 'model.eucrustp3','DATA/crustmap/eucrustp3.cmap')
- call get_value_string(eucrustp4, 'model.eucrustp4','DATA/crustmap/eucrustp4.cmap')
- call get_value_string(eucrustp5, 'model.eucrustp5','DATA/crustmap/eucrustp5.cmap')
- call get_value_string(eucrustp6, 'model.eucrustp6','DATA/crustmap/eucrustp6.cmap')
- call get_value_string(eucrustp7, 'model.eucrustp7','DATA/crustmap/eucrustp7.cmap')
-
- call get_value_string(eucrusts3, 'model.eucrusts3','DATA/crustmap/eucrusts3.cmap')
- call get_value_string(eucrusts4, 'model.eucrusts4','DATA/crustmap/eucrusts4.cmap')
- call get_value_string(eucrusts5, 'model.eucrusts5','DATA/crustmap/eucrusts5.cmap')
- call get_value_string(eucrusts6, 'model.eucrusts6','DATA/crustmap/eucrusts6.cmap')
- call get_value_string(eucrusts7, 'model.eucrusts7','DATA/crustmap/eucrusts7.cmap')
-
-
-
- open(unit=1,file=eucrustt3,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%thickness(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustt4,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%thickness(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustt5,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%thickness(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustt6,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%thickness(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustt7,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%thickness(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
-
-
- open(unit=1,file=eucrustr3,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%density(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustr4,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%density(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustr5,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%density(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustr6,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%density(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustr7,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%density(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
-
-
- open(unit=1,file=eucrustp3,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocp(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustp4,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocp(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustp5,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocp(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustp6,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocp(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrustp7,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocp(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
-
-
- open(unit=1,file=eucrusts3,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocs(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrusts4,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocs(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrusts5,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocs(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrusts6,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocs(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- open(unit=1,file=eucrusts7,status='old',action='read')
- do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocs(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
- enddo
- close(1)
-
- GC_V%thicknessnp(:) = 0.0
- GC_V%thicknesssp(:) = 0.0
- GC_V%densitynp(:) = 0.0
- GC_V%densitysp(:) = 0.0
- GC_V%velocpnp(:) = 0.0
- GC_V%velocpsp(:) = 0.0
- GC_V%velocsnp(:) = 0.0
- GC_V%velocssp(:) = 0.0
-
- !compute average values for north and southpole
- do l=1,NLAYERS_CRUSTMAP
- do i=1,360*CRUSTMAP_RESOLUTION
- GC_V%thicknessnp(l) = GC_V%thicknessnp(l)+GC_V%thickness(1,i,l)
- GC_V%thicknesssp(l) = GC_V%thicknesssp(l)+GC_V%thickness(180*CRUSTMAP_RESOLUTION,i,l)
- GC_V%densitynp(l) = GC_V%densitynp(l)+GC_V%density(1,i,l)
- GC_V%densitysp(l) = GC_V%densitysp(l)+GC_V%density(180*CRUSTMAP_RESOLUTION,i,l)
- GC_V%velocpnp(l) = GC_V%velocpnp(l)+GC_V%velocp(1,i,l)
- GC_V%velocpsp(l) = GC_V%velocpsp(l)+GC_V%velocp(180*CRUSTMAP_RESOLUTION,i,l)
- GC_V%velocsnp(l) = GC_V%velocsnp(l)+GC_V%velocs(1,i,l)
- GC_V%velocssp(l) = GC_V%velocssp(l)+GC_V%velocs(180*CRUSTMAP_RESOLUTION,i,l)
- enddo
- GC_V%thicknessnp(l) = GC_V%thicknessnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%thicknesssp(l) = GC_V%thicknesssp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%densitynp(l) = GC_V%densitynp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%densitysp(l) = GC_V%densitysp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%velocpnp(l) = GC_V%velocpnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%velocpsp(l) = GC_V%velocpsp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%velocsnp(l) = GC_V%velocsnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%velocssp(l) = GC_V%velocssp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
-
-! print *,'thicknessnp(',l,')',GC_V%thicknessnp(l)
- enddo
-
-
- end subroutine read_general_crustmap
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine model_crustmaps(lat,lon,x,vp,vs,rho,moho,found_crust,GC_V,elem_in_crust)
-
-! Matthias Meschede
-! read smooth crust2.0 model (0.25 degree resolution) with eucrust
-! based on software routines provided with the crust2.0 model by Bassin et al.
-!
-
- implicit none
- include "constants.h"
-
-!Matthias Meschede
- !model_crustmaps_variables
- type model_crustmaps_variables
- sequence
- double precision, dimension(180*CRUSTMAP_RESOLUTION,&
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
-
- double precision thicknessnp(NLAYERS_CRUSTMAP)
- double precision densitynp(NLAYERS_CRUSTMAP)
- double precision velocpnp(NLAYERS_CRUSTMAP)
- double precision velocsnp(NLAYERS_CRUSTMAP)
- double precision thicknesssp(NLAYERS_CRUSTMAP)
- double precision densitysp(NLAYERS_CRUSTMAP)
- double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
-
- end type model_crustmaps_variables
- type (model_crustmaps_variables) GC_V
- !model_crustmaps_variables
-
-
- double precision lat,lon,x,vp,vs,rho,moho
- logical found_crust,elem_in_crust
- double precision h_sed,h_uc
- double precision x3,x4,x5,x6,x7,scaleval
- double precision vps(NLAYERS_CRUSTMAP),vss(NLAYERS_CRUSTMAP),rhos(NLAYERS_CRUSTMAP),thicks(NLAYERS_CRUSTMAP)
-
- call read_crustmaps(lat,lon,vps,vss,rhos,thicks,GC_V)
-
- x3 = (R_EARTH-thicks(1)*1000.0d0)/R_EARTH
- h_sed = thicks(1) + thicks(2)
- x4 = (R_EARTH-h_sed*1000.0d0)/R_EARTH
- h_uc = h_sed + thicks(3)
- x5 = (R_EARTH-h_uc*1000.0d0)/R_EARTH
- x6 = (R_EARTH-(h_uc+thicks(4))*1000.0d0)/R_EARTH
- x7 = (R_EARTH-(h_uc+thicks(4)+thicks(5))*1000.0d0)/R_EARTH
-
- found_crust = .true.
-! if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST &
-! .and. h_sed > MINIMUM_SEDIMENT_THICKNESS) then
- if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST ) then
- vp = vps(1)
- vs = vss(1)
- rho = rhos(1)
-! else if(x > x4 .and. INCLUDE_SEDIMENTS_CRUST &
-! .and. h_sed > MINIMUM_SEDIMENT_THICKNESS) then
- else if(x > x4 .and. INCLUDE_SEDIMENTS_CRUST ) then
- vp = vps(2)
- vs = vss(2)
- rho = rhos(2)
- else if(x > x5) then
- vp = vps(3)
- vs = vss(3)
- rho = rhos(3)
- else if(x > x6) then
- vp = vps(4)
- vs = vss(4)
- rho = rhos(4)
- else if(x > x7 .or. elem_in_crust) then
- vp = vps(5)
- vs = vss(5)
- rho = rhos(5)
- 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(4)+thicks(5))*1000.0d0/R_EARTH
- else
- scaleval = dsqrt(PI*GRAV*RHOAV)
- vp = 20.0*1000.0d0/(R_EARTH*scaleval)
- vs = 20.0*1000.0d0/(R_EARTH*scaleval)
- rho = 20.0*1000.0d0/RHOAV
- endif
-
- moho = (h_uc+thicks(4)+thicks(5))*1000.0d0/R_EARTH
-
- end subroutine model_crustmaps
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine read_crustmaps(lat,lon,velp,vels,rhos,thicks,GC_V)
-
-! crustal vp and vs in km/s, layer thickness in km
-
- implicit none
- include "constants.h"
-
-
-! argument variables
- double precision lat,lon
- double precision rhos(5),thicks(5),velp(5),vels(5)
-!Matthias Meschede
- !model_crustmaps_variables
- type model_crustmaps_variables
- sequence
- double precision, dimension(180*CRUSTMAP_RESOLUTION,&
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
-
- double precision thicknessnp(NLAYERS_CRUSTMAP)
- double precision densitynp(NLAYERS_CRUSTMAP)
- double precision velocpnp(NLAYERS_CRUSTMAP)
- double precision velocsnp(NLAYERS_CRUSTMAP)
- double precision thicknesssp(NLAYERS_CRUSTMAP)
- double precision densitysp(NLAYERS_CRUSTMAP)
- double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
-
- end type model_crustmaps_variables
- type (model_crustmaps_variables) GC_V
- !model_crustmaps_variables
-
- !-------------------------------
- ! work-around to avoid jacobian problems when stretching mesh elements;
- ! one could also try to slightly change the shape of the doulbing element bricks (which cause the problem)...
- !
- ! defines a "critical" region to have at least a 1-degree smoothing;
- ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
- double precision,parameter :: LAT_CRITICAL_EUROPE = 50.0d0
- double precision,parameter :: LON_CRITICAL_EUROPE = 22.0d0
- double precision,parameter :: CRITICAL_RANGE_EUROPE = 50.0d0
-
- ! defines a "critical" region around the andes to have at least a 1-degree smoothing;
- ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
- double precision,parameter :: LAT_CRITICAL_ANDES = -20.0d0
- double precision,parameter :: LON_CRITICAL_ANDES = -70.0d0
- double precision,parameter :: CRITICAL_RANGE_ANDES = 70.0d0
-
- ! sampling rate for CAP points
- integer, parameter :: NTHETA = 4
- integer, parameter :: NPHI = 20
- !-------------------------------
-
-! local variables
- double precision weightup,weightleft,weightul,weightur,weightll,weightlr
- double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
- double precision rhol(NLAYERS_CRUSTMAP),thickl(NLAYERS_CRUSTMAP), &
- velpl(NLAYERS_CRUSTMAP),velsl(NLAYERS_CRUSTMAP)
- double precision weightl,cap_degree,dist
- double precision h_sed
- integer num_points
- integer i,ipoin,iupcolat,ileftlng,irightlng
-
-! 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) &
- write(*,*) lat,' ',lon, ' 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
-
- ! by defaults uses only 1 point location
- num_points = 1
-
- ! checks if inside/outside of critical region for mesh stretching
- if( SMOOTH_CRUST ) then
- dist = dsqrt( (lon-LAT_CRITICAL_EUROPE)**2 + (lat-LAT_CRITICAL_EUROPE )**2 )
- if( dist < CRITICAL_RANGE_EUROPE ) then
- ! sets up smoothing points
- ! by default uses CAP smoothing with crustmap resolution, e.g. 1/4 degree
- cap_degree = 1.d0 / CRUSTMAP_RESOLUTION
-
- ! increases cap smoothing degree
- ! scales between -1 at center and 0 at border
- dist = dist / CRITICAL_RANGE_EUROPE - 1.0d0
- ! shifts value to 1 at center and 0 to the border with exponential decay
- dist = 1.0d0 - exp( - dist*dist*10.0d0 )
- ! increases smoothing degree inside of critical region
- cap_degree = cap_degree + dist
-
- ! gets smoothing points and weights
- call CAP_vardegree(lon,lat,xlon,xlat,weight,cap_degree,NTHETA,NPHI)
- num_points = NTHETA*NPHI
- endif
- dist = dsqrt( (lon-LON_CRITICAL_ANDES)**2 + (lat-LAT_CRITICAL_ANDES )**2 )
- if( dist < CRITICAL_RANGE_ANDES ) then
- ! sets up smoothing points
- ! by default uses CAP smoothing with crustmap resolution, e.g. 1/4 degree
- cap_degree = 1.d0 / CRUSTMAP_RESOLUTION
-
- ! increases cap smoothing degree
- ! scales between -1 at center and 0 at border
- dist = dist / CRITICAL_RANGE_ANDES - 1.0d0
- ! shifts value to 1 at center and 0 to the border with exponential decay
- dist = 1.0d0 - exp( - dist*dist*10.0d0 )
- ! increases smoothing degree inside of critical region
- cap_degree = cap_degree + dist
-
- ! gets smoothing points and weights
- call CAP_vardegree(lon,lat,xlon,xlat,weight,cap_degree,NTHETA,NPHI)
- num_points = NTHETA*NPHI
- endif
- endif
-
- ! initializes
- velp(:) = 0.0d0
- vels(:) = 0.0d0
- rhos(:) = 0.0d0
- thicks(:) = 0.0d0
-
- ! loops over weight points
- do ipoin=1,num_points
- ! checks if more than one weighting points are taken
- if( num_points > 1 ) then
- lat = xlat(ipoin)
- lon = xlon(ipoin)
- ! weighting value
- weightl = weight(ipoin)
- else
- weightl = 1.0d0
- endif
-
- ! gets crust value indices
- call ibilinearmap(lat,lon,iupcolat,ileftlng,weightup,weightleft)
-
- ! interpolates location and crust values
- if(iupcolat==0) then
- weightup=weightup*2
- else if(iupcolat==180*CRUSTMAP_RESOLUTION) then
- weightup=2*weightup-1
- endif
-
- if(ileftlng==360*CRUSTMAP_RESOLUTION) then
- irightlng=1
- else
- irightlng=ileftlng+1
- endif
-
- weightul=weightup*weightleft
- weightur=weightup*(1.0-weightleft)
- weightll=(1.0-weightup)*weightleft
- weightlr=(1.0-weightup)*(1.0-weightleft)
-
- if(iupcolat==0) then
- ! north pole
- do i=1,NLAYERS_CRUSTMAP
- thickl(i)=weightul*GC_V%thicknessnp(i)+weightur*GC_V%thicknessnp(i)+&
- weightll*GC_V%thickness(1,ileftlng,i)+weightlr*GC_V%thickness(1,irightlng,i)
-
- rhol(i)=weightul*GC_V%densitynp(i)+weightur*GC_V%densitynp(i)+&
- weightll*GC_V%density(1,ileftlng,i)+weightlr*GC_V%density(1,irightlng,i)
- velpl(i)=weightul*GC_V%velocpnp(i)+weightur*GC_V%velocpnp(i)+&
- weightll*GC_V%velocp(1,ileftlng,i)+weightlr*GC_V%velocp(1,irightlng,i)
- velsl(i)=weightul*GC_V%velocsnp(i)+weightur*GC_V%velocsnp(i)+&
- weightll*GC_V%velocs(1,ileftlng,i)+weightlr*GC_V%velocs(1,irightlng,i)
- enddo
- elseif(iupcolat==180*CRUSTMAP_RESOLUTION) then
- ! south pole
- do i=1,NLAYERS_CRUSTMAP
- thickl(i)=weightul*GC_V%thickness(iupcolat,ileftlng,i)+weightur*GC_V%thickness(iupcolat,irightlng,i)+&
- weightll*GC_V%thicknesssp(i)+weightlr*GC_V%thicknesssp(i)
- rhol(i)=weightul*GC_V%density(iupcolat,ileftlng,i)+weightur*GC_V%density(iupcolat,irightlng,i)+&
- weightll*GC_V%densitysp(i)+weightlr*GC_V%densitysp(i)
- velpl(i)=weightul*GC_V%velocp(iupcolat,ileftlng,i)+weightur*GC_V%velocp(iupcolat,irightlng,i)+&
- weightll*GC_V%velocpsp(i)+weightlr*GC_V%velocpsp(i)
- velsl(i)=weightul*GC_V%velocs(iupcolat,ileftlng,i)+weightur*GC_V%velocs(iupcolat,irightlng,i)+&
- weightll*GC_V%velocssp(i)+weightlr*GC_V%velocssp(i)
- enddo
- else
- do i=1,NLAYERS_CRUSTMAP
- thickl(i)=weightul*GC_V%thickness(iupcolat,ileftlng,i)+weightur*GC_V%thickness(iupcolat,irightlng,i)+&
- weightll*GC_V%thickness(iupcolat+1,ileftlng,i)+weightlr*GC_V%thickness(iupcolat+1,irightlng,i)
- rhol(i)=weightul*GC_V%density(iupcolat,ileftlng,i)+weightur*GC_V%density(iupcolat,irightlng,i)+&
- weightll*GC_V%density(iupcolat+1,ileftlng,i)+weightlr*GC_V%density(iupcolat+1,irightlng,i)
- velpl(i)=weightul*GC_V%velocp(iupcolat,ileftlng,i)+weightur*GC_V%velocp(iupcolat,irightlng,i)+&
- weightll*GC_V%velocp(iupcolat+1,ileftlng,i)+weightlr*GC_V%velocp(iupcolat+1,irightlng,i)
- velsl(i)=weightul*GC_V%velocs(iupcolat,ileftlng,i)+weightur*GC_V%velocs(iupcolat,irightlng,i)+&
- weightll*GC_V%velocs(iupcolat+1,ileftlng,i)+weightlr*GC_V%velocs(iupcolat+1,irightlng,i)
- ! thicks(i)=1.0
- ! rhos(i)=1.0
- ! velp(i)=1.0
- ! vels(i)=1.0i
- enddo
- endif
-
- ! sediment thickness
- h_sed = thickl(1) + thickl(2)
-
- ! takes upper crust value if sediment too thin
- if( h_sed < MINIMUM_SEDIMENT_THICKNESS ) then
- velpl(1) = velpl(3)
- velpl(2) = velpl(3)
- velsl(1) = velsl(3)
- velsl(2) = velsl(3)
- rhol(1) = rhol(3)
- rhol(2) = rhol(3)
- endif
-
- ! total, smoothed values
- rhos(:) = rhos(:) + weightl*rhol(:)
- thicks(:) = thicks(:) + weightl*thickl(:)
- velp(:) = velp(:) + weightl*velpl(:)
- vels(:) = vels(:) + weightl*velsl(:)
- enddo
-
- end subroutine read_crustmaps
-
-!--------------------------------------------------------------------------------------------
-
- subroutine ibilinearmap(lat,lng,iupcolat,ileftlng,weightup,weightleft)
-
- implicit none
- include "constants.h"
-
-
-! argument variables
- double precision weightup,weightleft
- double precision lat,lng, xlng
- double precision buffer
- integer iupcolat
- integer ileftlng
-
- if(lat > 90.0d0 .or. lat < -90.0d0 .or. lng > 180.0d0 .or. lng < -180.0d0) &
- stop 'error in latitude/longitude range in icolat_ilon'
-
- if(lng<0) then
- xlng=lng+360.0
- else
- xlng=lng
- endif
-
- buffer=0.5+((90.0-lat)*CRUSTMAP_RESOLUTION)
- iupcolat=int(buffer)
- weightup=1.0-(buffer-dble(iupcolat))
-
- if(iupcolat<0) iupcolat=0
- if(iupcolat>180*CRUSTMAP_RESOLUTION) iupcolat=180*CRUSTMAP_RESOLUTION
-
-
- buffer=0.5+(xlng*CRUSTMAP_RESOLUTION)
- ileftlng=int(buffer)
- weightleft=1.0-(buffer-dble(ileftlng))
-
- if(ileftlng<1) ileftlng=360*CRUSTMAP_RESOLUTION
- if(ileftlng>360*CRUSTMAP_RESOLUTION) ileftlng=1
-
-
-
- end subroutine ibilinearmap
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-!
-! subroutine ilatlng(lat,lng,icolat,ilng)
-!
-! implicit none
-! include "constants.h"
-!
-!
-! ! argument variables
-! double precision lat,lng, xlng
-! integer icolat,ilng
-!
-! if(lat > 90.0d0 .or. lat < -90.0d0 .or. lng > 180.0d0 .or. lng < -180.0d0) &
-! stop 'error in latitude/longitude range in icolat_ilon'
-!
-! if(lng<0) then
-! xlng=lng+360.0
-! else
-! xlng=lng
-! endif
-!
-! icolat=int(1+((90.0-lat)*CRUSTMAP_RESOLUTION))
-! ! icolat=10
-! if(icolat == 180*CRUSTMAP_RESOLUTION+1) icolat=180*CRUSTMAP_RESOLUTION
-! ilng=int(1+(xlng*CRUSTMAP_RESOLUTION))
-! ! ilng=10
-! if(ilng == 360*CRUSTMAP_RESOLUTION+1) ilng=360*CRUSTMAP_RESOLUTION
-!
-! if(icolat>180*CRUSTMAP_RESOLUTION .or. icolat<1) stop 'error in routine icolat_ilon'
-! if(ilng<1 .or. ilng>360*CRUSTMAP_RESOLUTION) stop 'error in routine icolat_ilon'
-!
-! end subroutine ilatlng
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_eucrust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_eucrust.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_eucrust.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,429 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! EUCRUST-07
-!
-! Tesauro, M., M. K. Kaban and S. A. P. L. Cloetingh, 2008.
-! Eucrust-07: A New Reference Model for the European Crust,
-! Geophysical Research Letters, 35: p. L05313.208
-!--------------------------------------------------------------------------------------------------
-
- subroutine model_eucrust_broadcast(myrank,EUCM_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
- ! EUcrust
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
- integer :: myrank
- integer :: ier
-
- ! EUcrust07 Vp crustal structure
- if( myrank == 0 ) call read_EuCrust(EUCM_V)
-
- ! broadcast the information read on the master to the nodes
- call MPI_BCAST(EUCM_V%num_eucrust,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- if( myrank /= 0 ) then
- allocate(EUCM_V%eucrust_vp_uppercrust(EUCM_V%num_eucrust),EUCM_V%eucrust_vp_lowercrust(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_mohodepth(EUCM_V%num_eucrust),EUCM_V%eucrust_basement(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_ucdepth(EUCM_V%num_eucrust), EUCM_V%eucrust_lon(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_lat(EUCM_V%num_eucrust))
- endif
-
- call MPI_BCAST(EUCM_V%eucrust_lat(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_lon(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_vp_uppercrust(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_vp_lowercrust(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_mohodepth(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_basement(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_ucdepth(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- end subroutine model_eucrust_broadcast
-
-!----------------------------------------------------------------------------------------------------
-
- subroutine read_EuCrust(EUCM_V)
-
- implicit none
-
- include "constants.h"
-
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
-
- ! local variables
- character(len=80):: line
- character(len=150):: filename
- integer:: i,ierror
- double precision:: vp_uppercrust,vp_lowercrust,vp_avg,topo,basement
- double precision:: upper_lower_depth,moho_depth,lat,lon
-
- ! original file size entries
- EUCM_V%num_eucrust = 36058
-
- allocate(EUCM_V%eucrust_vp_uppercrust(EUCM_V%num_eucrust),EUCM_V%eucrust_vp_lowercrust(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_mohodepth(EUCM_V%num_eucrust),EUCM_V%eucrust_basement(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_ucdepth(EUCM_V%num_eucrust), EUCM_V%eucrust_lon(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_lat(EUCM_V%num_eucrust))
-
- EUCM_V%eucrust_vp_uppercrust(:) = 0.0
- EUCM_V%eucrust_vp_lowercrust(:) = 0.0
- EUCM_V%eucrust_mohodepth(:) = 0.0
- EUCM_V%eucrust_basement(:) = 0.0
- EUCM_V%eucrust_ucdepth(:) = 0.0
-
- ! opens data file
- call get_value_string(filename, 'model.eu', 'DATA/eucrust-07/ds01.txt')
- open(unit=11,file=filename,status='old',action='read')
-
- ! skip first line
- read(11,*)
-
- ! data
- do i=1,36058
-
- read(11,'(a80)',iostat=ierror) line
- if(ierror .ne. 0 ) stop
-
- read(line,*)lon,lat,vp_uppercrust,vp_lowercrust,vp_avg,topo,basement,upper_lower_depth,moho_depth
-
- ! stores moho values
- EUCM_V%eucrust_lon(i) = lon
- EUCM_V%eucrust_lat(i) = lat
- EUCM_V%eucrust_vp_uppercrust(i) = vp_uppercrust
- EUCM_V%eucrust_vp_lowercrust(i) = vp_lowercrust
- EUCM_V%eucrust_mohodepth(i) = moho_depth
- EUCM_V%eucrust_basement(i) = basement
- EUCM_V%eucrust_ucdepth(i) = upper_lower_depth
-
- enddo
- close(11)
-
- end subroutine read_EuCrust
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine model_eucrust(lat,lon,x,vp,found_crust,EUCM_V)
-
- implicit none
-
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
- double precision :: lat,lon,x,vp
- logical :: found_crust
- double precision :: lon_min,lon_max,lat_min,lat_max
- double precision, external:: crust_eu
-
- ! initializes
- vp = 0.d0
-
- ! eucrust boundary region
- lon_min = -24.875
- lon_max = 35.375
-
- lat_min = 34.375
- lat_max = 71.375
-
- found_crust = .false.
- if( lon < lon_min .or. lon > lon_max ) return
- if( lat < lat_min .or. lat > lat_max ) return
-
- ! smoothing over 1.0 degrees
- call eu_cap_smoothing(lat,lon,x,vp,found_crust,EUCM_V)
-
- ! without smoothing
- !vp = crust_eu(lat,lon,x,vp,found_crust,EUCM_V)
-
- end subroutine model_eucrust
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- double precision function crust_eu(lat,lon,x,vp,found_crust,EUCM_V)
-
-! returns Vp at the specific location lat/lon
-
- implicit none
-
- include "constants.h"
-
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
- double precision :: lat,lon,x,vp !,vs,rho,moho
- logical :: found_crust
-
- double precision :: longitude_min,longitude_max,latitude_min,latitude_max
- double precision :: h_basement,h_uc,h_moho,x3,x4,x5
- double precision :: scaleval
-
- integer :: i,j
- integer,parameter :: ilons = 242 ! number of different longitudes
- integer,parameter :: ilats = 149 ! number of different latitudes
-
- ! eucrust boundary region
- longitude_min = -24.875
- longitude_max = 35.375
-
- latitude_min = 34.375
- latitude_max = 71.375
-
- found_crust = .false.
- crust_eu = 0.0
- if( lon < longitude_min .or. lon > longitude_max ) return
- if( lat < latitude_min .or. lat > latitude_max ) return
-
- ! search
- do i=1,ilons-1
- if( lon >= EUCM_V%eucrust_lon(i) .and. lon < EUCM_V%eucrust_lon(i+1) ) then
- do j=0,ilats-1
- if(lat>=EUCM_V%eucrust_lat(i+j*ilons) .and. lat<EUCM_V%eucrust_lat(i+(j+1)*ilons)) then
-
- h_basement = EUCM_V%eucrust_basement(i+j*ilons)
- h_uc = EUCM_V%eucrust_ucdepth(i+j*ilons)
- h_moho = EUCM_V%eucrust_mohodepth(i+j*ilons)
-
- x3=(R_EARTH - h_basement*1000.0d0)/R_EARTH
- x4=(R_EARTH - h_uc*1000.0d0)/R_EARTH
- x5=(R_EARTH - h_moho*1000.0d0)/R_EARTH
-
- scaleval = dsqrt(PI*GRAV*RHOAV)
-
- if( x > x3 .and. INCLUDE_SEDIMENTS_CRUST &
- .and. h_basement > MINIMUM_SEDIMENT_THICKNESS) then
- ! above sediment basement, returns average upper crust value
- ! since no special sediment values are given
- found_crust = .true.
- vp = EUCM_V%eucrust_vp_uppercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
- crust_eu = vp
- return
- else if( x > x4 ) then
- found_crust = .true.
- vp = EUCM_V%eucrust_vp_uppercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
- crust_eu = vp
- return
- else if( x > x5 ) then
- found_crust = .true.
- vp = EUCM_V%eucrust_vp_lowercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
- crust_eu = vp
- return
- endif
- return
- endif
- enddo
- endif
- enddo
-
- end function crust_eu
-
-!
-!--------------------------------------------------------------------------------------------------
-!
- subroutine eu_cap_smoothing(lat,lon,radius,value,found,EUCM_V)
-
-! smooths with a cap of size CAP (in degrees)
-! using NTHETA points in the theta direction (latitudal)
-! and NPHI in the phi direction (longitudal).
-! The cap is rotated to the North Pole.
-
- implicit none
- include "constants.h"
-
- ! argument variables
- double precision lat,lon,radius
- double precision :: value
- logical :: found
-
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
- integer, parameter :: NTHETA = 4
- integer, parameter :: NPHI = 10
- double precision, parameter :: CAP = 1.0d0*PI/180.0d0 ! 1 degree smoothing
-
- double precision,external :: crust_eu
-
- ! 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,valuel
- 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)
-
- ! 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 as is, without smoothing
- ! value = func(lat,lon,x,value,found,EUCM_V)
- ! 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
-
- ! at this point:
- !
- ! xlat(i),xlon(i) are point locations to be used for interpolation
- ! with weights weight(i)
-
- ! integrates value
- value = 0.0d0
- do i=1,npoints
- valuel = crust_eu(xlat(i),xlon(i),radius,value,found,EUCM_V)
- value = value + weight(i)*valuel
- enddo
-
- if( abs(value) < TINYVAL) found = .false.
-
- end subroutine eu_cap_smoothing
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_gapp2.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_gapp2.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_gapp2.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-!
-! GAP P2 model - Global automatic parameterization model
-!
-! 3D Vp mantle model (version P2) from Masayuki Obayashi
-!
-!--------------------------------------------------------------------------------------------------
-
-
- module gapp2_mantle_model_constants
- ! data file resolution
- integer, parameter :: ma=228,mo=576,mr=32,mr1=64
- integer no,na,nnr,nr1
- real dela,delo
- ! allocatable model arrays
- real,dimension(:),allocatable :: dep,dep1,vp1
- real,dimension(:,:,:),allocatable :: vp3
- end module gapp2_mantle_model_constants
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine model_gapp2_broadcast(myrank)
-
-! standard routine to setup model
-
- use gapp2_mantle_model_constants
-
- implicit none
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
- integer :: myrank
- integer :: ier
-
- ! allocates arrays only when called and needed
- allocate(dep(0:mr),dep1(0:mr1),vp1(0:mr1),vp3(ma,mo,mr), &
- stat=ier)
- if( ier /= 0 ) then
- call exit_mpi(myrank,'error allocation GAP model')
- endif
-
- ! the variables read are declared in the module
- if(myrank == 0) call read_mantle_gapmodel()
-
- ! master process broadcasts data to all processes
- call MPI_BCAST( dep,mr+1,MPI_REAL,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(dep1,mr1+1,MPI_REAL,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST( vp1,mr1+1,MPI_REAL,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST( vp3,ma*mo*mr,MPI_REAL,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST( nnr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST( nr1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST( no,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST( na,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST( dela,1,MPI_REAL,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST( delo,1,MPI_REAL,0,MPI_COMM_WORLD,ier)
-
- end subroutine model_gapp2_broadcast
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine read_mantle_gapmodel()
-
- use gapp2_mantle_model_constants
-
- implicit none
- include "constants.h"
- integer i,ir,ia,io
- character(len=150) GAPP2
-
-!...........................................input data
-
- ! default model: 3dvpGAP_P2
- call get_value_string(GAPP2, 'model.GAPP2', 'DATA/3dvpGAP_P2')
-
- ! reads in GAP-P2 model from Obayashi
- open(unit=10,file=GAPP2,status='old',action='read')
-
- read(10,'(3i4,2f10.6)') no,na,nnr,dela,delo
- read(10,'(34f8.2)') (dep(i),i=0,nnr)
- read(10,*) nr1
- read(10,'(67f8.2)') (dep1(i),i=0,nr1)
- read(10,'(67f8.3)') (vp1(i),i=0,nr1)
- do ir=1,nnr
- do ia=1,na
- read(10,'(256f7.3)') (vp3(ia,io,ir),io=1,no)
- enddo
- enddo
- write(6,*) vp3(1,1,1),vp3(na,no,nnr)
- close(10)
-
- end subroutine read_mantle_gapmodel
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine mantle_gapmodel(radius,theta,phi,dvs,dvp,drho)
-
- use gapp2_mantle_model_constants
-
- implicit none
- include "constants.h"
- integer id,ia,io,icon
- real d,dtheta,dphi
-
- double precision radius,theta,phi,dvs,dvp,drho
-
-! factor to convert perturbations in shear speed to perturbations in density
- double precision, parameter :: SCALE_VS = 1.40d0
- double precision, parameter :: SCALE_RHO = 0.0d0
-
- double precision, parameter :: R_EARTH_ = 6371.d0
- double precision, parameter :: ZERO_ = 0.d0
-
-!.....................................
-
- dvs = ZERO_
- dvp = ZERO_
- drho = ZERO_
-
- ! increments in latitude/longitude (in rad)
- dtheta = dela * PI / 180.0
- dphi = delo * PI / 180.0
-
- ! depth given in km
- d=R_EARTH_-radius*R_EARTH_
-
- call d2id(d,nnr,dep,id,icon)
- if(icon.ne.0) then
- write(6,*)icon
- write(6,*) radius,theta,phi,dvp,dvs,drho
- endif
-
- ! latitude
- if(theta.ge.PI) then
- ia = na
- else
- ia = theta / dtheta + 1
- endif
- ! longitude
- if(phi .lt. 0.0d0) phi = phi + 2.*PI
- io=phi / dphi + 1
- if(io.gt.no) io=io-no
-
- ! velocity and density perturbations
- dvp = vp3(ia,io,id)/100.d0
- dvs = SCALE_VS*dvp
- drho = SCALE_RHO*dvs
-
- end subroutine mantle_gapmodel
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine d2id(d,mr,di,id,icon)
-!.................................................................
-! radial section index for a given depth d
-!.................................................................
-! d i depth(km)
-! mr i number of radial division
-! di i depth table
-! id o depth section index for d
-! shallow .... di(id-1) <= d < di(id) .... deep
-! icon o condition code
-! 0:normal, -99:above the surface, 99:below the cmb
-!.................................................................
- integer i, mr, id, icon
- real d,dmax,dmin
- real di(0:mr)
- icon=0
- dmax=di(mr)
- dmin=di(0)
- if(d.gt.dmax) then
- icon=99
- else if(d.lt.dmin) then
- icon=-99
- else if(d.eq.dmax) then
- id=mr+1
- else
- do i = 0, mr
- if(d.lt.di(i)) then
- id=i
- goto 900
- endif
- enddo
- end if
-900 continue
-
-!..................................................................
- return
-
- end subroutine d2id
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_gll.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_gll.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_gll.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,345 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! GLL
-!
-! based on modified GLL mesh output from mesher
-!
-! used for iterative inversion procedures
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_gll_broadcast(myrank,MGLL_V,NSPEC)
-
-! standard routine to setup model
-
- use meshfem3D_models_par,only: TRANSVERSE_ISOTROPY
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
- include "precision.h"
-
- ! GLL model_variables
- type model_gll_variables
- sequence
- ! tomographic iteration model on GLL points
- double precision :: scale_velocity,scale_density
- ! isotropic model
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vs_new,vp_new,rho_new
- ! transverse isotropic model
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vsv_new,vpv_new, &
- vsh_new,vph_new,eta_new
- logical :: MODEL_GLL
- logical,dimension(3) :: dummy_pad ! padding 3 bytes to align the structure
- end type model_gll_variables
- type (model_gll_variables) MGLL_V
-
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC
- integer :: myrank
-
- ! local parameters
- double precision :: scaleval
- real(kind=CUSTOM_REAL) :: min,max,min_all,max_all
- integer :: ier
-
- ! allocates arrays
- ! differs for isotropic model or transverse isotropic models
- if( .not. TRANSVERSE_ISOTROPY ) then
- ! isotropic model
- allocate( MGLL_V%vp_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
- allocate( MGLL_V%vs_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
- else
- ! transverse isotropic model
- allocate( MGLL_V%vpv_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
- allocate( MGLL_V%vph_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
- allocate( MGLL_V%vsv_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
- allocate( MGLL_V%vsh_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
- allocate( MGLL_V%eta_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
- endif
- allocate( MGLL_V%rho_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
-
- ! reads in model files for each process
- call read_gll_model(myrank,MGLL_V,NSPEC)
-
- ! checks velocity range
- if( .not. TRANSVERSE_ISOTROPY ) then
-
- ! isotropic model
- if( myrank == 0 ) then
- write(IMAIN,*)'model GLL: isotropic'
- endif
-
- ! Vs
- max = maxval( MGLL_V%vs_new )
- min = minval( MGLL_V%vs_new )
- call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
- call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
- if( myrank == 0 ) then
- write(IMAIN,*) ' vs new min/max: ',min_all,max_all
- endif
- ! Vp
- max = maxval( MGLL_V%vp_new )
- min = minval( MGLL_V%vp_new )
- call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
- call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
- if( myrank == 0 ) then
- write(IMAIN,*) ' vp new min/max: ',min_all,max_all
- endif
- ! density
- max = maxval( MGLL_V%rho_new )
- min = minval( MGLL_V%rho_new )
- call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
- call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
- if( myrank == 0 ) then
- write(IMAIN,*) ' rho new min/max: ',min_all,max_all
- write(IMAIN,*)
- endif
-
- else
-
- ! transverse isotropic model
- if( myrank == 0 ) then
- write(IMAIN,*)'model GLL: transverse isotropic'
- endif
-
- ! Vsv
- max = maxval( MGLL_V%vsv_new )
- min = minval( MGLL_V%vsv_new )
- call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
- call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
- if( myrank == 0 ) then
- write(IMAIN,*) ' vsv new min/max: ',min_all,max_all
- endif
- ! Vsh
- max = maxval( MGLL_V%vsh_new )
- min = minval( MGLL_V%vsh_new )
- call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
- call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
- if( myrank == 0 ) then
- write(IMAIN,*) ' vsh new min/max: ',min_all,max_all
- endif
- ! Vpv
- max = maxval( MGLL_V%vpv_new )
- min = minval( MGLL_V%vpv_new )
- call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
- call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
- if( myrank == 0 ) then
- write(IMAIN,*) ' vpv new min/max: ',min_all,max_all
- endif
- ! Vph
- max = maxval( MGLL_V%vph_new )
- min = minval( MGLL_V%vph_new )
- call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
- call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
- if( myrank == 0 ) then
- write(IMAIN,*) ' vph new min/max: ',min_all,max_all
- endif
- ! density
- max = maxval( MGLL_V%rho_new )
- min = minval( MGLL_V%rho_new )
- call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
- call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
- if( myrank == 0 ) then
- write(IMAIN,*) ' rho new min/max: ',min_all,max_all
- endif
- ! eta
- max = maxval( MGLL_V%eta_new )
- min = minval( MGLL_V%eta_new )
- call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
- call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
- if( myrank == 0 ) then
- write(IMAIN,*) ' eta new min/max: ',min_all,max_all
- write(IMAIN,*)
- endif
-
- endif
-
- ! non-dimensionalizes model values
- ! (SPECFEM3D_GLOBE uses non-dimensionalized values in subsequent computations)
- ! scaling values
- ! (model velocities must be given as km/s)
- scaleval = dsqrt(PI*GRAV*RHOAV)
- MGLL_V%scale_velocity = 1000.0d0/(R_EARTH*scaleval)
- MGLL_V%scale_density = 1000.0d0/RHOAV
- if( .not. TRANSVERSE_ISOTROPY ) then
- ! non-dimensionalize isotropic values
- MGLL_V%vp_new = MGLL_V%vp_new * MGLL_V%scale_velocity
- MGLL_V%vs_new = MGLL_V%vs_new * MGLL_V%scale_velocity
- MGLL_V%rho_new = MGLL_V%rho_new * MGLL_V%scale_density
- else
- ! non-dimensionalize
- ! transverse isotropic model
- MGLL_V%vpv_new = MGLL_V%vpv_new * MGLL_V%scale_velocity
- MGLL_V%vph_new = MGLL_V%vph_new * MGLL_V%scale_velocity
- MGLL_V%vsv_new = MGLL_V%vsv_new * MGLL_V%scale_velocity
- MGLL_V%vsh_new = MGLL_V%vsh_new * MGLL_V%scale_velocity
- MGLL_V%rho_new = MGLL_V%rho_new * MGLL_V%scale_density
- ! eta is already non-dimensional
- endif
-
- end subroutine model_gll_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine read_gll_model(myrank,MGLL_V,NSPEC)
-
- use meshfem3D_models_par,only: TRANSVERSE_ISOTROPY
-
- implicit none
-
- include "constants.h"
-
- ! GLL model_variables
- type model_gll_variables
- sequence
- ! tomographic iteration model on GLL points
- double precision :: scale_velocity,scale_density
- ! isotropic model
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vs_new,vp_new,rho_new
- ! transverse isotropic model
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vsv_new,vpv_new, &
- vsh_new,vph_new,eta_new
- logical :: MODEL_GLL
- logical,dimension(3) :: dummy_pad ! padding 3 bytes to align the structure
- end type model_gll_variables
- type (model_gll_variables) MGLL_V
-
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC
- integer :: myrank
-
- !--------------------------------------------------------------------
- ! USER PARAMETER
-
- character(len=150),parameter:: MGLL_path = 'DATA/GLL/'
- !--------------------------------------------------------------------
-
- ! local parameters
- integer :: ier
- character(len=150) :: prname
-
- if( myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*)'reading in model from ',trim(MGLL_path)
- endif
-
- ! only crust and mantle
- write(prname,'(a,i6.6,a)') MGLL_path(1:len_trim(MGLL_path))//'proc',myrank,'_reg1_'
-
- ! reads in model for each partition
- if( .not. TRANSVERSE_ISOTROPY ) then
- ! isotropic model
- ! vp mesh
- open(unit=27,file=prname(1:len_trim(prname))//'vp_new.bin',&
- status='old',action='read',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- write(IMAIN,*) 'error opening: ',prname(1:len_trim(prname))//'vp_new.bin'
- call exit_MPI(myrank,'error model gll')
- endif
- read(27) MGLL_V%vp_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
- close(27)
-
- ! vs mesh
- open(unit=27,file=prname(1:len_trim(prname))//'vs_new.bin', &
- status='old',action='read',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',prname(1:len_trim(prname))//'vs_new.bin'
- call exit_MPI(myrank,'error model gll')
- endif
- read(27) MGLL_V%vs_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
- close(27)
-
- else
-
- ! transverse isotropic model
- ! vp mesh
- open(unit=27,file=prname(1:len_trim(prname))//'vpv_new.bin',&
- status='old',action='read',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- write(IMAIN,*) 'error opening: ',prname(1:len_trim(prname))//'vpv_new.bin'
- call exit_MPI(myrank,'error model gll')
- endif
- read(27) MGLL_V%vpv_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
- close(27)
-
- open(unit=27,file=prname(1:len_trim(prname))//'vph_new.bin',&
- status='old',action='read',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- write(IMAIN,*) 'error opening: ',prname(1:len_trim(prname))//'vph_new.bin'
- call exit_MPI(myrank,'error model gll')
- endif
- read(27) MGLL_V%vph_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
- close(27)
-
- ! vs mesh
- open(unit=27,file=prname(1:len_trim(prname))//'vsv_new.bin', &
- status='old',action='read',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',prname(1:len_trim(prname))//'vsv_new.bin'
- call exit_MPI(myrank,'error model gll')
- endif
- read(27) MGLL_V%vsv_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
- close(27)
-
- open(unit=27,file=prname(1:len_trim(prname))//'vsh_new.bin', &
- status='old',action='read',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',prname(1:len_trim(prname))//'vsh_new.bin'
- call exit_MPI(myrank,'error model gll')
- endif
- read(27) MGLL_V%vsh_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
- close(27)
-
- ! eta mesh
- open(unit=27,file=prname(1:len_trim(prname))//'eta_new.bin', &
- status='old',action='read',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',prname(1:len_trim(prname))//'eta_new.bin'
- call exit_MPI(myrank,'error model gll')
- endif
- read(27) MGLL_V%eta_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
- close(27)
-
- endif
-
- ! rho mesh
- open(unit=27,file=prname(1:len_trim(prname))//'rho_new.bin', &
- status='old',action='read',form='unformatted',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening: ',prname(1:len_trim(prname))//'rho_new.bin'
- call exit_MPI(myrank,'error model gll')
- endif
- read(27) MGLL_V%rho_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
- close(27)
-
- end subroutine read_gll_model
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_heterogen_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_heterogen_mantle.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_heterogen_mantle.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,220 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! HMM
-!
-! generic heterogeneous mantle model
-!--------------------------------------------------------------------------------------------------
-
- subroutine model_heterogen_mntl_broadcast(myrank,HMM)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
- ! model_heterogen_m_variables
- type model_heterogen_m_variables
- sequence
- double precision rho_in(N_R*N_THETA*N_PHI)
- end type model_heterogen_m_variables
-
- type (model_heterogen_m_variables) HMM
- ! model_heterogen_m_variables
-
- integer :: myrank
- integer :: ier
-
- if(myrank == 0) then
- write(IMAIN,*) 'Reading in model_heterogen_mantle.'
- call read_heterogen_mantle_model(HMM)
- write(IMAIN,*) 'model_heterogen_mantle is read in.'
- endif
-
- ! broadcast the information read on the master to the nodes
- call MPI_BCAST(HMM%rho_in,N_R*N_THETA*N_PHI,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- if(myrank == 0) then
- write(IMAIN,*) 'model_heterogen_mantle is broadcast.'
- write(IMAIN,*) 'First value in HMM:',HMM%rho_in(1)
- write(IMAIN,*) 'Last value in HMM:',HMM%rho_in(N_R*N_THETA*N_PHI)
- endif
-
- end subroutine model_heterogen_mntl_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
-!
-! NOTE: CURRENTLY THIS ROUTINE ONLY WORKS FOR N_R=N_THETA=N_PHI !!!!!
-!
-
- subroutine read_heterogen_mantle_model(HMM)
-
- implicit none
-
- include "constants.h"
-
- integer i,j
-
-! model_heterogen_m_variables
- type model_heterogen_m_variables
- sequence
- double precision rho_in(N_R*N_THETA*N_PHI)
- end type model_heterogen_m_variables
-
- type (model_heterogen_m_variables) HMM
-! model_heterogen_m_variables
-
-
-! open heterogen.dat
- open(unit=10,file='./DATA/heterogen/heterogen.dat',access='direct',&
- form='formatted',recl=20,status='old',action='read')
-
- j = N_R*N_THETA*N_PHI
-
- do i = 1,j
- read(10,rec=i,fmt='(F20.15)') HMM%rho_in(i)
- end do
-
- close(10)
-
- end subroutine read_heterogen_mantle_model
-
-!====================================================================
-
- subroutine model_heterogen_mantle(radius,theta,phi,dvs,dvp,drho,HMM)
-
- implicit none
-
- include "constants.h"
-
- ! variable declaration
- double precision radius,theta,phi ! input coordinates
- double precision x,y,z ! input converted to cartesian
- double precision drho,dvp,dvs ! output anomaly values
- double precision x_low,x_high ! x values used to interpolate
- double precision y_low,y_high ! y values used to interpolate
- double precision z_low,z_high ! z values used to interpolate
- double precision delta,delta2 ! weigts in record# and in interpolation
- double precision rho1,rho2,rho3,rho4,rho5,rho6,rho7,rho8 ! rho values at the interpolation points
- double precision r_inner,r_outer ! lower and upper domain bounds for r
- integer rec_read ! nr of record to be read from heterogen.dat (direct access file)
- double precision a,b,c ! substitutions in interpolation algorithm (weights)
-
-
-! model_heterogen_m_variables
- type model_heterogen_m_variables
- sequence
- double precision rho_in(N_R*N_THETA*N_PHI)
- end type model_heterogen_m_variables
-
- type (model_heterogen_m_variables) HMM
-! model_heterogen_m_variables
-
- radius = radius*R_EARTH
- r_inner = 3.500d6 !lower bound for heterogeneity zone
-! NOTE: r_outer NEEDS TO BE (just) SMALLER THAN R_EARTH!!!!!!!!
- r_outer = R_EARTH-1.0d1 !6.300d6 !upper bound for heterogeneity zone (lower mantle: e.g. 4.500d6)
-
- delta = 2.*R_EARTH/(real(N_R-1))
- delta2 = 2.*R_EARTH/(real(N_R-2))
- !delta2 = 2.*R_EARTH/(real(N_R))
-
- if ((radius >= r_inner) .and. (radius <= r_outer)) then
- ! convert spherical point to cartesian point, move origin to corner
- x = R_EARTH + radius*sin(theta)*cos(phi)
- y = R_EARTH + radius*sin(theta)*sin(phi)
- z = R_EARTH + radius*cos(theta)
-
- ! determine which points to search for in heterogen.dat
- ! find x_low,y_low,z_low etc.
- x_low = floor(x/delta2) + 1
- x_high = x_low + 1
- y_low = floor(y/delta2) + 1
- y_high = y_low + 1
- z_low = floor(z/delta2) + 1
- z_high = z_low + 1
-
- ! rho1 at: x_low y_low z_low
- rec_read = 1+(x_low*N_R*N_R)+(y_low*N_R)+z_low
- rho1 = HMM%rho_in(rec_read)
-
- ! rho2 at: x_low y_high z_low
- rec_read = 1+(x_low*N_R*N_R)+(y_high*N_R)+z_low
- rho2 = HMM%rho_in(rec_read)
-
- ! rho3 at: x_high y_low z_low
- rec_read = 1+(x_high*N_R*N_R)+(y_low*N_R)+z_low
- rho3 = HMM%rho_in(rec_read)
-
- ! rho4 at: x_high y_high z_low
- rec_read = 1+(x_high*N_R*N_R)+(y_high*N_R)+z_low
- rho4 = HMM%rho_in(rec_read)
-
- ! rho5 at: x_low y_low z_high
- rec_read = 1+(x_low*N_R*N_R)+(y_low*N_R)+z_high
- rho5 = HMM%rho_in(rec_read)
-
- ! rho6 at: x_low y_high z_high
- rec_read = 1+(x_low*N_R*N_R)+(y_high*N_R)+z_high
- rho6 = HMM%rho_in(rec_read)
-
- ! rho7 at: x_high y_low z_high
- rec_read = 1+(x_high*N_R*N_R)+(y_low*N_R)+z_high
- rho7 = HMM%rho_in(rec_read)
-
- ! rho8 at: x_high y_high z_high
- rec_read = 1+(x_high*N_R*N_R)+(y_high*N_R)+z_high
- rho8 = HMM%rho_in(rec_read)
-
- ! perform linear interpolation between the 8 points
- a = (x-x_low*delta)/delta ! weight for x
- b = (y-y_low*delta)/delta ! weight for y
- c = (z-z_low*delta)/delta ! weight for z
-
- drho = rho1*(1.-a)*(1.-b)*(1.-c) + rho2*(1.-a)*b*(1.-c) + &
- & rho3*a*(1.-b)*(1.-c) + rho4*a*b*(1.-c) + rho5*(1.-a)*(1.-b)*c + &
- & rho6*(1.-a)*b*c + rho7*a*(1.-b)*c + rho8*a*b*c
-
- ! calculate delta vp,vs from the interpolated delta rho
- dvp = (0.55/0.30)*drho
- dvs = (1.00/0.30)*drho
-
- else !outside of heterogeneity domain
- drho = 0.
- dvp = 0.
- dvs = 0.
- end if
-
- end subroutine model_heterogen_mantle
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_iasp91.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_iasp91.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_iasp91.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,252 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! IASP91
-!
-! Spherically symmetric isotropic IASP91 model [Kennett and Engdahl, 1991]
-!
-! B. L. N. Kennett and E. R. Engdahl, Traveltimes for global earthquake location
-! and phase identification, Geophysical Journal International, vol. 105, p. 429-465 (1991)
-!--------------------------------------------------------------------------------------------------
-
-
- 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)
-
-
-! we use the density model of PREM (or close to PREM in the crust)
-! because IASP91 does not provide a density model.
-! Note that "ttimes" from the official IASP91 package uses a slightly different
-! model: scaling of the P wave velocity based on Birch's law. Both options are fine.
-
- implicit none
-
- include "constants.h"
-
-! given a normalized radius x, gives the non-dimensionalized 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 slightly 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 ! r
-
- endif ! check_doubling_flag
-
-
- ! assigns model values
-
- !
- !--- 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
-
- 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
-
- ! make sure Vs is zero in the outer core even if roundoff errors on depth
- ! also set fictitious attenuation for Qkappa to a very high value (attenuation is not used in the fluid)
- if(idoubling == IFLAG_OUTER_CORE_NORMAL) then
- vs = 0.d0
- Qkappa = 0.d0
- Qmu = ATTENUATION_COMP_MAXIMUM
- 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/model_jp1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp1d.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp1d.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,208 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! JP1D
-!
-! 1-D Japan model used as reference model for the 3-D model JP3D by Zhao et al. 1994
-!--------------------------------------------------------------------------------------------------
-
-
-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-dimensionalized 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/model_jp3d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp3d.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp3d.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1494 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! JP3D
-!
-! 3D japan Vp velocity model
-!
-! based on:
-!
-! 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
-!
-!
-! Last Time Modified by Min Chen, Caltech, 03/14/2008
-!
-!--------------------------------------------------------------------------------------------------
-
- subroutine model_jp3d_broadcast(myrank,JP3DM_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
-
- integer :: myrank
- integer :: ier
-
- if(myrank == 0) call read_jp3d_iso_zhao_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)
-
-
- end subroutine model_jp3d_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_jp3d_iso_zhao_model(JP3DM_V)
-
- implicit none
-
- include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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_jp3d_iso_zhao_model
-
-!
-!==========================================================================
-!
-
- subroutine model_jp3d_iso_zhao(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
- implicit none
-
- include "constants.h"
-
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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 model_jp3d_iso_zhao
-
-!
-!---------------------------------------------------------------
-!
-
- SUBROUTINE INPUT1(JP3DM_V)
- implicit none
-
- include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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"
-
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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"
-
-
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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"
-
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- 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
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- 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)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_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/model_ppm.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_ppm.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_ppm.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1429 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-!
-! PPM - point profile models
-!
-! for generic models given as depth profiles at lon/lat using a text-file format like:
-!
-! #lon(deg), lat(deg), depth(km), Vs-perturbation wrt PREM(%), Vs-PREM (km/s)
-! -10.00000 31.00000 40.00000 -1.775005 4.400000
-! -10.00000 32.00000 40.00000 -1.056823 4.400000
-! ...
-!
-!--------------------------------------------------------------------------------------------------
-
- module module_PPM
-
- include "constants.h"
-
- ! file
- character(len=150):: PPM_file_path = "./DATA/PPM/model.txt"
-
- ! smoothing parameters
- logical,parameter:: GAUSS_SMOOTHING = .false.
-
- double precision,parameter:: sigma_h = 10.0 ! 50.0 ! km, horizontal
- double precision,parameter:: sigma_v = 10.0 ! 20.0 ! km, vertical
-
- double precision,parameter:: pi_by180 = PI/180.0d0
- double precision,parameter:: degtokm = pi_by180*R_EARTH_KM
-
- double precision,parameter:: const_a = sigma_v/3.0
- double precision,parameter:: const_b = sigma_h/3.0/(R_EARTH_KM*pi_by180)
- integer,parameter:: NUM_GAUSSPOINTS = 10
-
- double precision,parameter:: pi_by2 = PI/2.0d0
- double precision,parameter:: radtodeg = 180.0d0/PI
-
- ! ----------------------
- ! scale perturbations in shear speed to perturbations in density and vp
- logical,parameter:: SCALE_MODEL = .false.
-
- ! factor to convert perturbations in shear speed to perturbations in density
- ! taken from s20rts (see also Qin, 2009, sec. 5.2)
- double precision, parameter :: SCALE_RHO = 0.40d0
-
- ! SCEC version 4 model relationship http://www.data.scec.org/3Dvelocity/
- !double precision, parameter :: SCALE_RHO = 0.254d0
-
- ! see: P wave seismic velocity and Vp/Vs ratio beneath the Italian peninsula from local earthquake tomography
- ! (Davide Scadi et al.,2008. tectonophysics)
- !! becomes unstable !!
- !double precision, parameter :: SCALE_VP = 1.75d0 ! corresponds to average vp/vs ratio
-
- ! Zhou et al. 2005: global upper-mantle structure from finite-frequency surface-wave tomography
- ! http://www.gps.caltech.edu/~yingz/pubs/Zhou_JGR_2005.pdf
- !double precision, parameter :: SCALE_VP = 0.5d0 ! by lab measurements Montagner & Anderson, 1989
-
- ! Qin et al. 2009, sec. 5.2
- double precision, parameter :: SCALE_VP = 0.588d0 ! by Karato, 1993
-
- end module module_PPM
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine model_ppm_broadcast(myrank,PPM_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
-! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
-
- integer :: myrank
- integer :: ier
-
- ! upper mantle structure
- if(myrank == 0) call read_model_ppm(PPM_V)
-
- ! broadcast the information read on the master to the nodes
- call MPI_BCAST(PPM_V%num_v,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%num_latperlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%num_lonperdepth,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- if( myrank /= 0 ) then
- allocate(PPM_V%lat(PPM_V%num_v),PPM_V%lon(PPM_V%num_v),PPM_V%depth(PPM_V%num_v),PPM_V%dvs(PPM_V%num_v))
- endif
- call MPI_BCAST(PPM_V%dvs(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%lat(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%lon(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%depth(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%maxlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%minlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%maxlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%minlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%maxdepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%mindepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%dlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%dlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%ddepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- end subroutine model_ppm_broadcast
-
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine read_model_ppm(PPM_V)
-
- use module_PPM
-
- implicit none
-
- ! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
-
- ! local parameters
- integer :: ier,counter,i
- double precision :: lon,lat,depth,dvs,vs
- character(len=150) :: filename,line
-
- call get_value_string(filename, 'model.PPM', trim(PPM_file_path))
-
- !e.g. mediterranean model
- ! counts entries
- counter=0
- open(unit=10,file=trim(filename),status='old',action='read',iostat=ier)
- if( ier /= 0 ) then
- write(IMAIN,*) ' error count opening: ',trim(filename)
- call exit_mpi(0,"error count opening model ppm")
- endif
-
- ! first line is text and will be ignored
- read(10,'(a150)') line
-
- ! counts number of data lines
- ier = 0
- do while (ier == 0 )
- read(10,*,iostat=ier) lon,lat,depth,dvs,vs
- if( ier == 0 ) then
- counter = counter + 1
- endif
- enddo
- close(10)
-
- PPM_V%num_v = counter
- if( counter < 1 ) then
- write(IMAIN,*)
- write(IMAIN,*) ' model PPM:',filename
- write(IMAIN,*) ' no values read in!!!!!!'
- write(IMAIN,*)
- write(IMAIN,*)
- call exit_mpi(0,' no model PPM ')
- else
- write(IMAIN,*)
- write(IMAIN,*) 'model PPM:',trim(filename)
- write(IMAIN,*) ' values: ',counter
- write(IMAIN,*)
- endif
-
- allocate(PPM_V%lat(counter),PPM_V%lon(counter),PPM_V%depth(counter),PPM_V%dvs(counter))
- PPM_V%min_dvs = 0.0
- PPM_V%max_dvs = 0.0
- PPM_V%dvs(:) = 0.0
-
- ! vs values
- open(unit=10,file=trim(filename),status='old',action='read',iostat=ier)
- if( ier /= 0 ) then
- write(IMAIN,*) ' error opening: ',trim(filename)
- call exit_mpi(0,"error opening model ppm")
- endif
- read(10,'(a150)') line ! first line is text
- counter=0
- ier = 0
- do while (ier == 0 )
- read(10,*,iostat=ier) lon,lat,depth,dvs,vs
- if( ier == 0 ) then
- counter = counter + 1
- PPM_V%lat(counter) = lat
- PPM_V%lon(counter) = lon
- PPM_V%depth(counter) = depth
- PPM_V%dvs(counter) = dvs/100.0
-
- !debug
- !if( abs(depth - 100.0) < 1.e-3) write(IMAIN,*) ' lon/lat/depth : ',lon,lat,depth,' dvs:',dvs
- endif
- enddo
- close(10)
- if( counter /= PPM_V%num_v ) then
- write(IMAIN,*)
- write(IMAIN,*) ' model PPM:',filename
- write(IMAIN,*) ' error values read in!!!!!!'
- write(IMAIN,*) ' expected: ',PPM_V%num_v
- write(IMAIN,*) ' got: ',counter
- call exit_mpi(0,' error model PPM ')
- endif
-
-
- ! gets depths (in km) of upper and lower limit
- PPM_V%minlat = minval( PPM_V%lat(1:PPM_V%num_v) )
- PPM_V%maxlat = maxval( PPM_V%lat(1:PPM_V%num_v) )
-
- PPM_V%minlon = minval( PPM_V%lon(1:PPM_V%num_v) )
- PPM_V%maxlon = maxval( PPM_V%lon(1:PPM_V%num_v) )
-
- PPM_V%mindepth = minval( PPM_V%depth(1:PPM_V%num_v) )
- PPM_V%maxdepth = maxval( PPM_V%depth(1:PPM_V%num_v) )
-
- PPM_V%min_dvs = minval(PPM_V%dvs(1:PPM_V%num_v))
- PPM_V%max_dvs = maxval(PPM_V%dvs(1:PPM_V%num_v))
-
- write(IMAIN,*) 'model PPM:'
- write(IMAIN,*) ' latitude min/max : ',PPM_V%minlat,PPM_V%maxlat
- write(IMAIN,*) ' longitude min/max: ',PPM_V%minlon,PPM_V%maxlon
- write(IMAIN,*) ' depth min/max : ',PPM_V%mindepth,PPM_V%maxdepth
- write(IMAIN,*)
- write(IMAIN,*) ' dvs min/max : ',PPM_V%min_dvs,PPM_V%max_dvs
- write(IMAIN,*)
- if( SCALE_MODEL ) then
- write(IMAIN,*) ' scaling: '
- write(IMAIN,*) ' rho: ',SCALE_RHO
- write(IMAIN,*) ' vp : ',SCALE_VP
- write(IMAIN,*)
- endif
- if( GAUSS_SMOOTHING ) then
- write(IMAIN,*) ' smoothing: '
- write(IMAIN,*) ' sigma horizontal : ',sigma_h
- write(IMAIN,*) ' sigma vertical : ',sigma_v
- write(IMAIN,*)
- endif
-
- ! steps lengths
- PPM_V%dlat = 0.0d0
- lat = PPM_V%lat(1)
- do i=1,PPM_V%num_v
- if( abs(lat - PPM_V%lat(i)) > 1.e-15 ) then
- PPM_V%dlat = PPM_V%lat(i) - lat
- exit
- endif
- enddo
-
- PPM_V%dlon = 0.0d0
- lon = PPM_V%lon(1)
- do i=1,PPM_V%num_v
- if( abs(lon - PPM_V%lon(i)) > 1.e-15 ) then
- PPM_V%dlon = PPM_V%lon(i) - lon
- exit
- endif
- enddo
-
- PPM_V%ddepth = 0.0d0
- depth = PPM_V%depth(1)
- do i=1,PPM_V%num_v
- if( abs(depth - PPM_V%depth(i)) > 1.e-15 ) then
- PPM_V%ddepth = PPM_V%depth(i) - depth
- exit
- endif
- enddo
-
- if( abs(PPM_V%dlat) < 1.e-15 .or. abs(PPM_V%dlon) < 1.e-15 .or. abs(PPM_V%ddepth) < 1.e-15) then
- write(IMAIN,*) ' model PPM:',filename
- write(IMAIN,*) ' error in delta values:'
- write(IMAIN,*) ' dlat : ',PPM_V%dlat,' dlon: ',PPM_V%dlon,' ddepth: ',PPM_V%ddepth
- call exit_mpi(0,' error model PPM ')
- else
- write(IMAIN,*) ' model increments:'
- write(IMAIN,*) ' ddepth: ',sngl(PPM_V%ddepth),' dlat:',sngl(PPM_V%dlat),' dlon:',sngl(PPM_V%dlon)
- write(IMAIN,*)
- endif
-
- PPM_V%num_latperlon = int( (PPM_V%maxlat - PPM_V%minlat) / PPM_V%dlat) + 1
- PPM_V%num_lonperdepth = int( (PPM_V%maxlon - PPM_V%minlon) / PPM_V%dlon ) + 1
-
- end subroutine read_model_ppm
-
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine model_ppm(radius,theta,phi,dvs,dvp,drho,PPM_V)
-
-! returns dvs,dvp and drho for given radius,theta,phi location
-
- use module_PPM
-
- implicit none
-
- ! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
-
- double precision radius,theta,phi,dvs,dvp,drho
-
- ! local parameters
- integer:: i,j,k
- double precision:: lat,lon,r_depth
- double precision:: min_dvs,max_dvs
-
- double precision:: g_dvs,g_depth,g_lat,g_lon,x,g_weight,weight_sum,weight_prod
-
- ! initialize
- dvs = 0.0d0
- dvp = 0.0d0
- drho = 0.0d0
-
- ! depth of given radius (in km)
- r_depth = R_EARTH_KM*(1.0 - radius) ! radius is normalized between [0,1]
- if(r_depth>PPM_V%maxdepth .or. r_depth < PPM_V%mindepth) return
-
- lat=(pi_by2-theta)*radtodeg
- if( lat < PPM_V%minlat .or. lat > PPM_V%maxlat ) return
-
- lon=phi*radtodeg
- if(lon>180.0d0) lon=lon-360.0d0
- if( lon < PPM_V%minlon .or. lon > PPM_V%maxlon ) return
-
- ! search location value
- if( .not. GAUSS_SMOOTHING ) then
- call get_PPMmodel_value(lat,lon,r_depth,PPM_V,dvs)
- return
- endif
-
- !write(IMAIN,*) ' model ppm at ',sngl(lat),sngl(lon),sngl(r_depth)
-
- ! loop over neighboring points
- dvs = 0.0
- weight_sum = 0.0
- do i=-NUM_GAUSSPOINTS,NUM_GAUSSPOINTS
- g_depth = r_depth + i*const_a
- do j=-NUM_GAUSSPOINTS,NUM_GAUSSPOINTS
- g_lon = lon + j*const_b
- do k=-NUM_GAUSSPOINTS,NUM_GAUSSPOINTS
- g_lat = lat + k*const_b
-
- call get_PPMmodel_value(g_lat,g_lon,g_depth,PPM_V,g_dvs)
-
- ! horizontal weighting
- x = (g_lat-lat)*degtokm
- call get_Gaussianweight(x,sigma_h,g_weight)
- g_dvs = g_dvs*g_weight
- weight_prod = g_weight
-
- x = (g_lon-lon)*degtokm
- call get_Gaussianweight(x,sigma_h,g_weight)
- g_dvs = g_dvs*g_weight
- weight_prod = weight_prod * g_weight
-
- !vertical weighting
- x = g_depth-r_depth
- call get_Gaussianweight(x,sigma_v,g_weight)
- g_dvs = g_dvs*g_weight
- weight_prod = weight_prod * g_weight
-
- ! averaging
- weight_sum = weight_sum + weight_prod
- dvs = dvs + g_dvs
- enddo
- enddo
- enddo
-
- if( weight_sum > 1.e-15) dvs = dvs / weight_sum
-
-
- ! store min/max
- max_dvs = PPM_V%max_dvs
- min_dvs = PPM_V%min_dvs
-
- if( dvs > max_dvs ) max_dvs = dvs
- if( dvs < min_dvs ) min_dvs = dvs
-
- PPM_V%max_dvs = max_dvs
- PPM_V%min_dvs = min_dvs
-
- !write(IMAIN,*) ' dvs = ',sngl(dvs),' weight: ',sngl(weight_sum),(sngl((2*PI*sigma_h**2)*sqrt(2*PI)*sigma_v))
-
- if( SCALE_MODEL ) then
- ! scale density and shear velocity
- drho = SCALE_RHO*dvs
- ! scale vp and shear velocity
- dvp = SCALE_VP*dvs
- endif
-
- end subroutine model_ppm
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine get_PPMmodel_value(lat,lon,depth,PPM_V,dvs)
-
- implicit none
-
- include "constants.h"
-
- ! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
-
- double precision lat,lon,depth,dvs
-
- !integer i,j,k
- !double precision r_top,r_bottom
-
- integer index,num_latperlon,num_lonperdepth
-
- dvs = 0.0
-
- if( lat > PPM_V%maxlat ) return
- if( lat < PPM_V%minlat ) return
- if( lon > PPM_V%maxlon ) return
- if( lon < PPM_V%minlon ) return
- if( depth > PPM_V%maxdepth ) return
- if( depth < PPM_V%mindepth ) return
-
- ! direct access: assumes having a regular interval spacing
- num_latperlon = PPM_V%num_latperlon ! int( (PPM_V%maxlat - PPM_V%minlat) / PPM_V%dlat) + 1
- num_lonperdepth = PPM_V%num_lonperdepth ! int( (PPM_V%maxlon - PPM_V%minlon) / PPM_V%dlon ) + 1
-
- index = int( (depth-PPM_V%mindepth)/PPM_V%ddepth )*num_lonperdepth*num_latperlon &
- + int( (lon-PPM_V%minlon)/PPM_V%dlon )*num_latperlon &
- + int( (lat-PPM_V%minlat)/PPM_V%dlat ) + 1
- dvs = PPM_V%dvs(index)
-
- ! ! loop-wise: slower performance
- ! do i=1,PPM_V%num_v
- ! ! depth
- ! r_top = PPM_V%depth(i)
- ! r_bottom = PPM_V%depth(i) + PPM_V%ddepth
- ! if( depth > r_top .and. depth <= r_bottom ) then
- ! ! longitude
- ! do j=i,PPM_V%num_v
- ! if( lon >= PPM_V%lon(j) .and. lon < PPM_V%lon(j)+PPM_V%dlon ) then
- ! ! latitude
- ! do k=j,PPM_V%num_v
- ! if( lat >= PPM_V%lat(k) .and. lat < PPM_V%lat(k)+PPM_V%dlat ) then
- ! dvs = PPM_V%dvs(k)
- ! return
- ! endif
- ! enddo
- ! endif
- ! enddo
- ! endif
- ! enddo
-
- end subroutine
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine get_Gaussianweight(x,sigma,weight)
-
- implicit none
-
- include "constants.h"
-
- double precision:: x,sigma,weight
-
- double precision,parameter:: one_over2pisqrt = 0.3989422804014327
-
- ! normalized version
- !weight = one_over2pisqrt*exp(-0.5*x*x/(sigma*sigma))/sigma
-
- ! only exponential
- weight = exp(-0.5*x*x/(sigma*sigma))
-
- end subroutine
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine smooth_model(myrank, nproc_xi,nproc_eta,&
- rho_vp,rho_vs,nspec_stacey, &
- iregion_code,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- xstore,ystore,zstore,rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
- nspec,HETEROGEN_3D_MANTLE, &
- NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
-
-! smooth model parameters
-
- implicit none
-
- include 'mpif.h'
- include "constants.h"
- include "precision.h"
-
- ! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
-
- integer :: myrank, nproc_xi, nproc_eta
-
- integer NEX_XI
-
- integer nspec,nspec_stacey,NCHUNKS
-
- logical ABSORBING_CONDITIONS
- logical HETEROGEN_3D_MANTLE
-
-! arrays with jacobian matrix
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
-! arrays with mesh parameters
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! for anisotropy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,dvpstore,kappavstore,kappahstore,&
- muvstore,muhstore,eta_anisostore
-
-! Stacey
- real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey)
- real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
-
- ! local parameters
- integer i,j,k,ispec
- integer iregion_code
-
- ! only include the neighboring 3 x 3 slices
- integer, parameter :: NSLICES = 3
- integer ,parameter :: NSLICES2 = NSLICES * NSLICES
-
- integer :: sizeprocs, ier, ixi, ieta
- integer :: islice(NSLICES2), islice0(NSLICES2), nums
-
- real(kind=CUSTOM_REAL) :: sigma_h, sigma_h2, sigma_h3, sigma_v, sigma_v2, sigma_v3
-
- real(kind=CUSTOM_REAL) :: x0, y0, z0, norm, norm_h, norm_v, element_size
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor, exp_val
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: jacobian, jacobian0
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xl, yl, zl, xx, yy, zz
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:),allocatable :: slice_jacobian
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:),allocatable :: slice_x, slice_y, slice_z
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:),allocatable :: slice_kernels
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ks_rho,ks_kv,ks_kh,ks_muv,ks_muh,ks_eta,ks_dvp,ks_rhovp,ks_rhovs
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: tk_rho,tk_kv,tk_kh,tk_muv,tk_muh,tk_eta,tk_dvp,tk_rhovp,tk_rhovs
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: bk
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable:: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: x, y, z
- real(kind=CUSTOM_REAL), dimension(nspec) :: cx0, cy0, cz0, cx, cy, cz
- double precision :: starttime
-
- integer :: ii, ispec2, rank, mychunk
-
- ! 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 all the weights in the cube
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
-
- real(kind=CUSTOM_REAL), parameter :: ZERO_ = 0.0_CUSTOM_REAL
-
- real(kind=CUSTOM_REAL) maxlat,maxlon,maxdepth
- real(kind=CUSTOM_REAL) minlat,minlon,mindepth
- real(kind=CUSTOM_REAL) radius,theta,phi,lat,lon,r_depth,margin_v,margin_h
- real(kind=CUSTOM_REAL) dist_h,dist_v
-
-!----------------------------------------------------------------------------------------------------
- ! smoothing parameters
- logical,parameter:: GAUSS_SMOOTHING = .false. ! set to true to use this smoothing routine
-
- sigma_h = 100.0 ! km, horizontal
- sigma_v = 100.0 ! km, vertical
-
- ! check if smoothing applies
- if( .not. GAUSS_SMOOTHING ) return
-!----------------------------------------------------------------------------------------------------
-
- ! check region: only smooth in mantle & crust
- if( iregion_code /= IREGION_CRUST_MANTLE ) return
-
-
- sizeprocs = NCHUNKS*NPROC_XI*NPROC_ETA
- element_size = (TWO_PI*R_EARTH/1000.d0)/(4*NEX_XI)
-
- if (myrank == 0) then
- write(IMAIN, *) "model smoothing defaults:"
- write(IMAIN, *) " NPROC_XI , NPROC_ETA, NCHUNKS: ",nproc_xi,nproc_eta,nchunks
- write(IMAIN, *) " total processors : ",sizeprocs
- write(IMAIN, *) " element size on surface(km): ",element_size
- write(IMAIN, *) " smoothing sigma horizontal : ",sigma_h," vertical: ", sigma_v
- endif
-
-
- if (nchunks == 0) call exit_mpi(myrank,'no chunks')
-
- element_size = element_size * 1000 ! e.g. 9 km on the surface, 36 km at CMB
- element_size = element_size / R_EARTH
-
- sigma_h = sigma_h * 1000.0 ! m
- sigma_h = sigma_h / R_EARTH ! scale
- sigma_v = sigma_v * 1000.0 ! m
- sigma_v = sigma_v / R_EARTH ! scale
-
- sigma_h2 = sigma_h ** 2
- sigma_v2 = sigma_v ** 2
-
- ! search radius
- sigma_h3 = 3.0 * sigma_h + element_size
- sigma_h3 = sigma_h3 ** 2
- sigma_v3 = 3.0 * sigma_v + element_size
- sigma_v3 = sigma_v3 ** 2
- ! theoretic normal value
- ! (see integral over -inf to +inf of exp[- x*x/(2*sigma) ] = sigma * sqrt(2*pi) )
- norm_h = 2.0*PI*sigma_h**2
- norm_v = sqrt(2.0*PI) * sigma_v
- norm = norm_h * norm_v
-
- if (myrank == 0) then
- write(IMAIN, *) " spectral elements : ",nspec
- write(IMAIN, *) " normalization factor : ",norm
- endif
-
- ! GLL points
- call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
- call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
- call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
- enddo
- enddo
- enddo
-
- ! ---- figure out the neighboring 8 or 7 slices: (ichunk,ixi,ieta) index start at 0------
- ! note: ichunk is set to CHUNK_AB etc., while mychunk starts from 0
- mychunk = myrank / (nproc_xi * nproc_eta)
- ieta = (myrank - mychunk * nproc_xi * nproc_eta) / nproc_xi
- ixi = myrank - mychunk * nproc_xi * nproc_eta - ieta * nproc_xi
-
- ! get the neighboring slices:
- call get_all_eight_slices(mychunk,ixi,ieta,&
- islice0(1),islice0(2),islice0(3),islice0(4),islice0(5),islice0(6),islice0(7),islice0(8),&
- nproc_xi,nproc_eta)
-
- ! remove the repeated slices (only 8 for corner slices in global case)
- islice(1) = myrank; j = 1
- do i = 1, 8
- if (.not. any(islice(1:i) == islice0(i)) .and. islice0(i) < sizeprocs) then
- j = j + 1
- islice(j) = islice0(i)
- endif
- enddo
- nums = j
-
- if( myrank == 0 ) then
- write(IMAIN, *) 'slices:',nums
- write(IMAIN, *) ' ',islice(1:nums)
- write(IMAIN, *)
- endif
-
- ! read in the topology files of the current and neighboring slices
- ! read in myrank slice
- xl(:,:,:,:) = xstore(:,:,:,:)
- yl(:,:,:,:) = ystore(:,:,:,:)
- zl(:,:,:,:) = zstore(:,:,:,:)
-
- ! build jacobian
- allocate(xix(NGLLX,NGLLY,NGLLZ,nspec),xiy(NGLLX,NGLLY,NGLLZ,nspec),xiz(NGLLX,NGLLY,NGLLZ,nspec))
- xix(:,:,:,:) = xixstore(:,:,:,:)
- xiy(:,:,:,:) = xiystore(:,:,:,:)
- xiz(:,:,:,:) = xizstore(:,:,:,:)
-
- allocate(etax(NGLLX,NGLLY,NGLLZ,nspec),etay(NGLLX,NGLLY,NGLLZ,nspec),etaz(NGLLX,NGLLY,NGLLZ,nspec))
- etax(:,:,:,:) = etaxstore(:,:,:,:)
- etay(:,:,:,:) = etaystore(:,:,:,:)
- etaz(:,:,:,:) = etazstore(:,:,:,:)
-
- allocate(gammax(NGLLX,NGLLY,NGLLZ,nspec),gammay(NGLLX,NGLLY,NGLLZ,nspec),gammaz(NGLLX,NGLLY,NGLLZ,nspec))
- gammax(:,:,:,:) = gammaxstore(:,:,:,:)
- gammay(:,:,:,:) = gammaystore(:,:,:,:)
- gammaz(:,:,:,:) = gammazstore(:,:,:,:)
-
-
- ! get the location of the center of the elements
- do ispec = 1, nspec
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- ! build jacobian
- ! 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 = xixl*(etayl*gammazl-etazl*gammayl) - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl)
-
- if( abs(jacobianl) > 1.e-25 ) then
- jacobianl = 1.0_CUSTOM_REAL / jacobianl
- else
- jacobianl = ZERO_
- endif
-
- jacobian(i,j,k,ispec) = jacobianl
- enddo
- enddo
- enddo
- cx0(ispec) = (xl(1,1,1,ispec) + xl(NGLLX,NGLLY,NGLLZ,ispec))*0.5
- cy0(ispec) = (yl(1,1,1,ispec) + yl(NGLLX,NGLLY,NGLLZ,ispec))*0.5
- cz0(ispec) = (zl(1,1,1,ispec) + zl(NGLLX,NGLLY,NGLLZ,ispec))*0.5
- enddo
- jacobian0(:,:,:,:) = jacobian(:,:,:,:)
-
- deallocate(xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
-
- if (myrank == 0) write(IMAIN, *) 'distributing locations, jacobians and model values ...'
- call mpi_barrier(MPI_COMM_WORLD,ier)
-
- ! get location/jacobian info from slices
- allocate( slice_x(NGLLX,NGLLY,NGLLZ,NSPEC,nums))
- allocate( slice_y(NGLLX,NGLLY,NGLLZ,NSPEC,nums))
- allocate( slice_z(NGLLX,NGLLY,NGLLZ,NSPEC,nums))
- allocate( slice_jacobian(NGLLX,NGLLY,NGLLZ,NSPEC,nums))
- do rank=0,sizeprocs-1
- if( rank == myrank) then
- jacobian(:,:,:,:) = jacobian0(:,:,:,:)
- x(:,:,:,:) = xstore(:,:,:,:)
- y(:,:,:,:) = ystore(:,:,:,:)
- z(:,:,:,:) = zstore(:,:,:,:)
- endif
- ! every process broadcasts its info
- call MPI_BCAST(x,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(y,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(z,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(jacobian,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
-
- ! only relevant process info gets stored
- do ii=1,nums
- if( islice(ii) == rank ) then
- slice_x(:,:,:,:,ii) = x(:,:,:,:)
- slice_y(:,:,:,:,ii) = y(:,:,:,:)
- slice_z(:,:,:,:,ii) = z(:,:,:,:)
- slice_jacobian(:,:,:,:,ii) = jacobian(:,:,:,:)
- endif
- enddo
- enddo
-
- ! arrays to smooth
- allocate( slice_kernels(NGLLX,NGLLY,NGLLZ,NSPEC,nums,9))
- do rank=0,sizeprocs-1
- if( rank == myrank) then
- ks_rho(:,:,:,:) = rhostore(:,:,:,:)
- ks_kv(:,:,:,:) = kappavstore(:,:,:,:)
- ks_kh(:,:,:,:) = kappahstore(:,:,:,:)
- ks_muv(:,:,:,:) = muvstore(:,:,:,:)
- ks_muh(:,:,:,:) = muhstore(:,:,:,:)
- ks_eta(:,:,:,:) = eta_anisostore(:,:,:,:)
- if( HETEROGEN_3D_MANTLE ) then
- ks_dvp(:,:,:,:) = dvpstore(:,:,:,:)
- endif
- if( ABSORBING_CONDITIONS ) then
- if( iregion_code == IREGION_CRUST_MANTLE) then
- ks_rhovp(:,:,:,1:nspec_stacey) = rho_vp(:,:,:,1:nspec_stacey)
- ks_rhovs(:,:,:,1:nspec_stacey) = rho_vs(:,:,:,1:nspec_stacey)
- endif
- endif
- ! in case of
- !if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
- ! or
- !if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
- ! or
- !if(ATTENUATION .and. ATTENUATION_3D) then
- ! one should add the c**store and tau_* arrays here as well
- endif
- ! every process broadcasts its info
- call MPI_BCAST(ks_rho,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ks_kv,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ks_kh,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ks_muv,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ks_muh,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ks_eta,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ks_dvp,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ks_rhovp,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ks_rhovs,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
-
- ! only relevant process info gets stored
- do ii=1,nums
- if( islice(ii) == rank ) then
- slice_kernels(:,:,:,:,ii,1) = ks_rho(:,:,:,:)
- slice_kernels(:,:,:,:,ii,2) = ks_kv(:,:,:,:)
- slice_kernels(:,:,:,:,ii,3) = ks_kh(:,:,:,:)
- slice_kernels(:,:,:,:,ii,4) = ks_muv(:,:,:,:)
- slice_kernels(:,:,:,:,ii,5) = ks_muh(:,:,:,:)
- slice_kernels(:,:,:,:,ii,6) = ks_eta(:,:,:,:)
- slice_kernels(:,:,:,:,ii,7) = ks_dvp(:,:,:,:)
- slice_kernels(:,:,:,:,ii,8) = ks_rhovp(:,:,:,:)
- slice_kernels(:,:,:,:,ii,9) = ks_rhovs(:,:,:,:)
- endif
- enddo
- enddo
-
- ! get the global maximum value of the original kernel file
- !call mpi_barrier(MPI_COMM_WORLD,ier)
- !call mpi_reduce(maxval(abs(muvstore(:,:,:,:))), max_old, 1, &
- ! CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
-
- if (myrank == 0) write(IMAIN, *) 'start looping over elements and points for smoothing ...'
-
-! loop over all the slices
- tk_rho(:,:,:,:) = 0.0_CUSTOM_REAL
- tk_kh(:,:,:,:) = 0.0_CUSTOM_REAL
- tk_kv(:,:,:,:) = 0.0_CUSTOM_REAL
- tk_muh(:,:,:,:) = 0.0_CUSTOM_REAL
- tk_muv(:,:,:,:) = 0.0_CUSTOM_REAL
- tk_eta(:,:,:,:) = 0.0_CUSTOM_REAL
- tk_dvp(:,:,:,:) = 0.0_CUSTOM_REAL
- tk_rhovp(:,:,:,:) = 0.0_CUSTOM_REAL
- tk_rhovs(:,:,:,:) = 0.0_CUSTOM_REAL
-
- bk(:,:,:,:) = 0.0_CUSTOM_REAL
- do ii = 1, nums
- if (myrank == 0) starttime = MPI_WTIME()
- if (myrank == 0) write(IMAIN, *) ' slice number = ', ii
-
- ! read in the topology, jacobian, calculate center of elements
- xx(:,:,:,:) = slice_x(:,:,:,:,ii)
- yy(:,:,:,:) = slice_y(:,:,:,:,ii)
- zz(:,:,:,:) = slice_z(:,:,:,:,ii)
- jacobian(:,:,:,:) = slice_jacobian(:,:,:,:,ii)
-
- ! get the location of the center of the elements
- do ispec2 = 1, nspec
- cx(ispec2) = (xx(1,1,1,ispec2) + xx(NGLLX,NGLLZ,NGLLY,ispec2))*0.5
- cy(ispec2) = (yy(1,1,1,ispec2) + yy(NGLLX,NGLLZ,NGLLY,ispec2))*0.5
- cz(ispec2) = (zz(1,1,1,ispec2) + zz(NGLLX,NGLLZ,NGLLY,ispec2))*0.5
- enddo
-
- !if (myrank == 0) write(IMAIN, *) ' location:',cx(1),cy(1),cz(1)
- !if (myrank == 0) write(IMAIN, *) ' dist:',(cx(1)-cx0(1))**2+(cy(1)-cy0(1))**2,(cz(1)-cz0(1))**2
- !if (myrank == 0) write(IMAIN, *) ' sigma:',sigma_h3,sigma_v3
-
- ! array values
- ks_rho(:,:,:,:) = slice_kernels(:,:,:,:,ii,1)
- ks_kv(:,:,:,:) = slice_kernels(:,:,:,:,ii,2)
- ks_kh(:,:,:,:) = slice_kernels(:,:,:,:,ii,3)
- ks_muv(:,:,:,:) = slice_kernels(:,:,:,:,ii,4)
- ks_muh(:,:,:,:) = slice_kernels(:,:,:,:,ii,5)
- ks_eta(:,:,:,:) = slice_kernels(:,:,:,:,ii,6)
- ks_dvp(:,:,:,:) = slice_kernels(:,:,:,:,ii,7)
- ks_rhovp(:,:,:,:) = slice_kernels(:,:,:,:,ii,8)
- ks_rhovs(:,:,:,:) = slice_kernels(:,:,:,:,ii,9)
-
- ! loop over elements to be smoothed in the current slice
- do ispec = 1, nspec
-
- if (myrank == 0 .and. mod(ispec,100) == 0 ) write(IMAIN, *) ' ispec ', ispec,' sec:',MPI_WTIME()-starttime
-
- ! --- only double loop over the elements in the search radius ---
- do ispec2 = 1, nspec
-
- ! calculates horizontal and vertical distance between two element centers
-
- ! vector approximation
- call get_distance_vec(dist_h,dist_v,cx0(ispec),cy0(ispec),cz0(ispec),&
- cx(ispec2),cy(ispec2),cz(ispec2))
-
- ! note: distances and sigmah, sigmav are normalized by R_EARTH
-
- ! checks distance between centers of elements
- if ( dist_h > sigma_h3 .or. abs(dist_v) > sigma_v3 ) cycle
-
-
-
- factor(:,:,:) = jacobian(:,:,:,ispec2) * wgll_cube(:,:,:) ! integration factors
-
- ! loop over GLL points of the elements in current slice (ispec)
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
-
- ! current point (i,j,k,ispec) location, cartesian coordinates
- x0 = xl(i,j,k,ispec)
- y0 = yl(i,j,k,ispec)
- z0 = zl(i,j,k,ispec)
-
- ! calculate weights based on gaussian smoothing
- call smoothing_weights_vec(x0,y0,z0,ispec2,sigma_h2,sigma_v2,exp_val,&
- xx(:,:,:,ispec2),yy(:,:,:,ispec2),zz(:,:,:,ispec2))
-
- ! adds GLL integration weights
- exp_val(:,:,:) = exp_val(:,:,:) * factor(:,:,:)
-
-
- ! smoothed kernel values
- tk_rho(i,j,k,ispec) = tk_rho(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_rho(:,:,:,ispec2))
- tk_kv(i,j,k,ispec) = tk_kv(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_kv(:,:,:,ispec2))
- tk_kh(i,j,k,ispec) = tk_kh(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_kh(:,:,:,ispec2))
- tk_muv(i,j,k,ispec) = tk_muv(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_muv(:,:,:,ispec2))
- tk_muh(i,j,k,ispec) = tk_muh(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_muh(:,:,:,ispec2))
- tk_eta(i,j,k,ispec) = tk_eta(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_eta(:,:,:,ispec2))
- tk_dvp(i,j,k,ispec) = tk_dvp(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_dvp(:,:,:,ispec2))
- tk_rhovp(i,j,k,ispec) = tk_rhovp(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_rhovp(:,:,:,ispec2))
- tk_rhovs(i,j,k,ispec) = tk_rhovs(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_rhovs(:,:,:,ispec2))
-
- ! normalization, integrated values of gaussian smoothing function
- bk(i,j,k,ispec) = bk(i,j,k,ispec) + sum(exp_val(:,:,:))
-
- enddo
- enddo
- enddo ! (i,j,k)
- enddo ! (ispec2)
- enddo ! (ispec)
- enddo ! islice
-
- if (myrank == 0) write(IMAIN, *) 'Done with integration ...'
-
- ! gets depths (in km) of upper and lower limit
- maxlat = PPM_V%maxlat
- minlat = PPM_V%minlat
-
- maxlon = PPM_V%maxlon
- minlon = PPM_V%minlon
-
- maxdepth = PPM_V%maxdepth
- mindepth = PPM_V%mindepth
-
- margin_v = sigma_v*R_EARTH/1000.0 ! in km
- margin_h = sigma_h*R_EARTH/1000.0 * 180.0/(R_EARTH_KM*PI) ! in degree
-
- ! computes the smoothed values
- do ispec = 1, nspec
-
- ! depth of given radius (in km)
- call xyz_2_rthetaphi(cx0(ispec),cy0(ispec),cz0(ispec),radius,theta,phi)
- r_depth = R_EARTH_KM - radius*R_EARTH_KM ! radius is normalized between [0,1]
- if(r_depth>=maxdepth+margin_v .or. r_depth+margin_v < mindepth) cycle
-
- lat=(PI/2.0d0-theta)*180.0d0/PI
- if( lat < minlat-margin_h .or. lat > maxlat+margin_h ) cycle
-
- lon=phi*180.0d0/PI
- if(lon>180.0d0) lon=lon-360.0d0
- if( lon < minlon-margin_h .or. lon > maxlon+margin_h ) cycle
-
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
-
- ! check if bk value has an entry
- if (abs(bk(i,j,k,ispec) ) > 1.e-25 ) then
-
- ! check if (integrated) normalization value is close to theoretically one
- if (abs(bk(i,j,k,ispec) - norm) > 1.e-3*norm ) then ! check the normalization criterion
- print *, 'Problem here --- ', myrank, ispec, i, j, k, bk(i,j,k,ispec), norm
- call exit_mpi(myrank, 'Error computing Gaussian function on the grid')
- endif
-
- rhostore(i,j,k,ispec) = tk_rho(i,j,k,ispec) / bk(i,j,k,ispec)
- kappavstore(i,j,k,ispec) = tk_kv(i,j,k,ispec) / bk(i,j,k,ispec)
- kappahstore(i,j,k,ispec) = tk_kh(i,j,k,ispec) / bk(i,j,k,ispec)
- muvstore(i,j,k,ispec) = tk_muv(i,j,k,ispec) / bk(i,j,k,ispec)
- muhstore(i,j,k,ispec) = tk_muh(i,j,k,ispec) / bk(i,j,k,ispec)
- eta_anisostore(i,j,k,ispec) = tk_eta(i,j,k,ispec) / bk(i,j,k,ispec)
- if( HETEROGEN_3D_MANTLE ) then
- dvpstore(i,j,k,ispec) = tk_dvp(i,j,k,ispec) / bk(i,j,k,ispec)
- endif
- endif
-
- enddo
- enddo
- enddo
- enddo
-
- if( ABSORBING_CONDITIONS ) then
- if( iregion_code == IREGION_CRUST_MANTLE) then
- do ispec = 1, nspec_stacey
-
- ! depth of given radius (in km)
- call xyz_2_rthetaphi(cx0(ispec),cy0(ispec),cz0(ispec),radius,theta,phi)
- r_depth = R_EARTH_KM - radius*R_EARTH_KM ! radius is normalized between [0,1]
- if(r_depth>=maxdepth+margin_v .or. r_depth+margin_v < mindepth) cycle
-
- lat=(PI/2.0d0-theta)*180.0d0/PI
- if( lat < minlat-margin_h .or. lat > maxlat+margin_h ) cycle
-
- lon=phi*180.0d0/PI
- if(lon>180.0d0) lon=lon-360.0d0
- if( lon < minlon-margin_h .or. lon > maxlon+margin_h ) cycle
-
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
-
- ! check if bk value has an entry
- if (abs(bk(i,j,k,ispec) ) > 1.e-25 ) then
- rho_vp(i,j,k,ispec) = tk_rhovp(i,j,k,ispec)/bk(i,j,k,ispec)
- rho_vs(i,j,k,ispec) = tk_rhovs(i,j,k,ispec)/bk(i,j,k,ispec)
- endif
-
- enddo
- enddo
- enddo
- enddo
- endif
- endif
-
- !if (myrank == 0) write(IMAIN, *) 'Maximum data value before smoothing = ', max_old
-
- ! the maximum value for the smoothed kernel
- !call mpi_barrier(MPI_COMM_WORLD,ier)
- !call mpi_reduce(maxval(abs(muvstore(:,:,:,:))), max_new, 1, &
- ! CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
-
- !if (myrank == 0) then
- ! write(IMAIN, *) 'Maximum data value after smoothing = ', max_new
- ! write(IMAIN, *)
- !endif
- !call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
- end subroutine
-
-!
-! -----------------------------------------------------------------------------
-!
- subroutine smoothing_weights_vec(x0,y0,z0,ispec2,sigma_h2,sigma_v2,exp_val,&
- xx_elem,yy_elem,zz_elem)
-
- implicit none
- include "constants.h"
-
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ),intent(out) :: exp_val
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ),intent(in) :: xx_elem, yy_elem, zz_elem
- real(kind=CUSTOM_REAL),intent(in) :: x0,y0,z0,sigma_h2,sigma_v2
- integer,intent(in) :: ispec2
-
- ! local parameters
- integer :: ii,jj,kk
- real(kind=CUSTOM_REAL) :: dist_h,dist_v
- !real(kind=CUSTOM_REAL) :: r0,r1,theta1
-
- ! >>>>>
- ! uniform sigma
- ! just to avoid compiler warning
- ii = ispec2
- !exp_val(:,:,:) = exp( -((xx(:,:,:,ispec2)-x0)**2+(yy(:,:,:,ispec2)-y0)**2 &
- ! +(zz(:,:,:,ispec2)-z0)**2 )/(2*sigma2) )*factor(:,:,:)
-
- ! from basin code smoothing:
- ! gaussian function
- !exp_val(:,:,:) = exp( -(xx(:,:,:,ispec2)-x0)**2/(sigma_h2) &
- ! -(yy(:,:,:,ispec2)-y0)**2/(sigma_h2) &
- ! -(zz(:,:,:,ispec2)-z0)**2/(sigma_v2) ) * factor(:,:,:)
- ! >>>>>
-
- do kk = 1, NGLLZ
- do jj = 1, NGLLY
- do ii = 1, NGLLX
- ! point in second slice
-
- ! vector approximation:
- call get_distance_vec(dist_h,dist_v,x0,y0,z0, &
- xx_elem(ii,jj,kk),yy_elem(ii,jj,kk),zz_elem(ii,jj,kk))
-
- ! gaussian function
- exp_val(ii,jj,kk) = exp( - dist_h*dist_h/sigma_h2 &
- - dist_v*dist_v/sigma_v2 ) ! * factor(ii,jj,kk)
-
- enddo
- enddo
- enddo
-
- end subroutine smoothing_weights_vec
-
-
-!
-! -----------------------------------------------------------------------------
-!
-
- subroutine get_distance_vec(dist_h,dist_v,x0,y0,z0,x1,y1,z1)
-
-! returns vector lengths as distances in radial and horizontal direction
-
- implicit none
- include "constants.h"
-
- real(kind=CUSTOM_REAL),intent(out) :: dist_h,dist_v
- real(kind=CUSTOM_REAL),intent(in) :: x0,y0,z0,x1,y1,z1
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: r0,r1,alpha
- real(kind=CUSTOM_REAL) :: vx,vy,vz
-
- ! vertical distance
- r0 = sqrt( x0*x0 + y0*y0 + z0*z0 ) ! length of first position vector
- r1 = sqrt( x1*x1 + y1*y1 + z1*z1 )
- dist_v = r1 - r0
- ! only for flat earth with z in depth: dist_v = sqrt( (cz(ispec2)-cz0(ispec))** 2)
-
- ! horizontal distance
- ! length of vector from point 0 to point 1
- ! assuming small earth curvature (since only for neighboring elements)
-
- ! scales r0 to have same length as r1
- alpha = r1 / r0
- vx = alpha * x0
- vy = alpha * y0
- vz = alpha * z0
-
- ! vector in horizontal between new r0 and r1
- vx = x1 - vx
- vy = y1 - vy
- vz = z1 - vz
-
- ! distance is vector length
- dist_h = sqrt( vx*vx + vy*vy + vz*vz )
-
- end subroutine get_distance_vec
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine get_all_eight_slices(ichunk,ixi,ieta,&
- ileft,iright,ibot,itop, ilb,ilt,irb,irt,&
- nproc_xi,nproc_eta)
-
- implicit none
-
- integer, intent(IN) :: ichunk,ixi,ieta,nproc_xi,nproc_eta
-
- integer, intent(OUT) :: ileft,iright,ibot,itop,ilb,ilt,irb,irt
- integer :: get_slice_number
-
-
- integer :: ichunk_left, islice_xi_left, islice_eta_left, &
- ichunk_right, islice_xi_right, islice_eta_right, &
- ichunk_bot, islice_xi_bot, islice_eta_bot, &
- ichunk_top, islice_xi_top, islice_eta_top, &
- ileft0,iright0,ibot0,itop0, &
- ichunk_left0, islice_xi_left0, islice_eta_left0, &
- ichunk_right0, islice_xi_right0, islice_eta_right0, &
- ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
- ichunk_top0, islice_xi_top0, islice_eta_top0
-
-
-! get the first 4 immediate slices
- call get_lrbt_slices(ichunk,ixi,ieta, &
- ileft, ichunk_left, islice_xi_left, islice_eta_left, &
- iright, ichunk_right, islice_xi_right, islice_eta_right, &
- ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
- itop, ichunk_top, islice_xi_top, islice_eta_top, &
- nproc_xi,nproc_eta)
-
-! get the 4 diagonal neighboring slices (actually 3 diagonal slices at the corners)
- ilb = get_slice_number(ichunk,ixi-1,ieta-1,nproc_xi,nproc_eta)
- ilt = get_slice_number(ichunk,ixi-1,ieta+1,nproc_xi,nproc_eta)
- irb = get_slice_number(ichunk,ixi+1,ieta-1,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk,ixi+1,ieta+1,nproc_xi,nproc_eta)
-
- if (ixi==0) then
- call get_lrbt_slices(ichunk_left,islice_xi_left,islice_eta_left, &
- ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
- iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
- ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
- itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
- nproc_xi,nproc_eta)
-
- if (ichunk == 0 .or. ichunk == 1 .or. ichunk == 3 .or. ichunk == 5) then
- ilb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- ilt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- else if (ichunk == 2) then
- ilb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- ilt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- else
- ilb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- ilt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- endif
- endif
-
- if (ixi==nproc_xi-1) then
- call get_lrbt_slices(ichunk_right,islice_xi_right,islice_eta_right, &
- ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
- iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
- ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
- itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
- nproc_xi,nproc_eta)
- if (ichunk == 0 .or. ichunk == 1 .or. ichunk == 3 .or. ichunk == 5) then
- irb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- else if (ichunk == 2) then
- irb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- else
- irb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- endif
- endif
-
- if (ieta==0) then
- call get_lrbt_slices(ichunk_bot,islice_xi_bot,islice_eta_bot, &
- ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
- iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
- ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
- itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
- nproc_xi,nproc_eta)
- if (ichunk == 1 .or. ichunk == 2) then
- ilb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- irb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- else if (ichunk == 3 .or. ichunk == 4) then
- ilb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- irb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- else if (ichunk == 0) then
- ilb = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- irb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- else
- ilb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- irb = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- endif
- endif
-
- if (ieta==nproc_eta-1) then
- call get_lrbt_slices(ichunk_top,islice_xi_top,islice_eta_top, &
- ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
- iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
- ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
- itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
- nproc_xi,nproc_eta)
-
- if (ichunk == 1 .or. ichunk == 4) then
- ilt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- else if (ichunk == 2 .or. ichunk == 3) then
- ilt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- else if (ichunk == 0) then
- ilt = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- else
- ilt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
- irt = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
- endif
-
- endif
-
- end subroutine get_all_eight_slices
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- subroutine get_lrbt_slices(ichunk,ixi,ieta, &
- ileft, ichunk_left, islice_xi_left, islice_eta_left, &
- iright, ichunk_right, islice_xi_right, islice_eta_right, &
- ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
- itop, ichunk_top, islice_xi_top, islice_eta_top, &
- nproc_xi,nproc_eta)
-
- implicit none
-
- integer, intent(IN) :: ichunk, ixi, ieta, nproc_xi, nproc_eta
- integer, intent(OUT) :: ileft, ichunk_left, islice_xi_left, islice_eta_left, &
- iright, ichunk_right, islice_xi_right, islice_eta_right, &
- ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
- itop, ichunk_top, islice_xi_top, islice_eta_top
-
- integer, parameter :: NCHUNKS = 6
-
- integer, dimension(NCHUNKS) :: chunk_left,chunk_right,chunk_bot,chunk_top, &
- slice_xi_left,slice_eta_left,slice_xi_right,slice_eta_right, &
- slice_xi_bot,slice_eta_bot,slice_xi_top,slice_eta_top
- integer :: get_slice_number
-
-! set up mapping arrays -- assume chunk/slice number starts from 0
- chunk_left(:) = (/2,6,6,1,6,4/) - 1
- chunk_right(:) = (/4,1,1,6,1,2/) - 1
- chunk_bot(:) = (/5,5,2,5,4,5/) - 1
- chunk_top(:) = (/3,3,4,3,2,3/) - 1
-
- slice_xi_left(:) = (/nproc_xi-1,nproc_xi-1,nproc_xi-1-ieta,nproc_xi-1,ieta,nproc_xi-1/)
- slice_eta_left(:) = (/ieta,ieta,nproc_eta-1,ieta,0,ieta/)
- slice_xi_right(:) = (/0,0,ieta,0,nproc_xi-1-ieta,0/)
- slice_eta_right(:) = (/ieta,ieta,nproc_eta-1,ieta,0,ieta/)
-
- slice_xi_bot(:) = (/nproc_xi-1,ixi,ixi,nproc_xi-1-ixi,nproc_xi-1-ixi,0/)
- slice_eta_bot(:) = (/nproc_eta-1-ixi,nproc_eta-1,nproc_eta-1,0,0,ixi/)
- slice_xi_top(:) = (/nproc_xi-1,ixi,nproc_xi-1-ixi,nproc_xi-1-ixi,ixi,0/)
- slice_eta_top(:) = (/ixi,0,nproc_eta-1,nproc_eta-1,0,nproc_eta-1-ixi /)
-
- ichunk_left = ichunk
- ichunk_right = ichunk
- ichunk_bot = ichunk
- ichunk_top = ichunk
-
- islice_xi_left = ixi-1
- islice_eta_left = ieta
- islice_xi_right = ixi+1
- islice_eta_right = ieta
-
- islice_xi_bot = ixi
- islice_eta_bot = ieta-1
- islice_xi_top = ixi
- islice_eta_top = ieta+1
-
- if (ixi == 0) then
- ichunk_left=chunk_left(ichunk+1)
- islice_xi_left=slice_xi_left(ichunk+1)
- islice_eta_left=slice_eta_left(ichunk+1)
- endif
- if (ixi == nproc_xi - 1) then
- ichunk_right=chunk_right(ichunk+1)
- islice_xi_right=slice_xi_right(ichunk+1)
- islice_eta_right=slice_eta_right(ichunk+1)
- endif
- if (ieta == 0) then
- ichunk_bot=chunk_bot(ichunk+1)
- islice_xi_bot=slice_xi_bot(ichunk+1)
- islice_eta_bot=slice_eta_bot(ichunk+1)
- endif
- if (ieta == nproc_eta - 1) then
- ichunk_top=chunk_top(ichunk+1)
- islice_xi_top=slice_xi_top(ichunk+1)
- islice_eta_top=slice_eta_top(ichunk+1)
- endif
-
- ileft = get_slice_number(ichunk_left,islice_xi_left,islice_eta_left,nproc_xi,nproc_eta)
- iright = get_slice_number(ichunk_right,islice_xi_right,islice_eta_right,nproc_xi,nproc_eta)
- ibot = get_slice_number(ichunk_bot,islice_xi_bot,islice_eta_bot,nproc_xi,nproc_eta)
- itop = get_slice_number(ichunk_top,islice_xi_top,islice_eta_top,nproc_xi,nproc_eta)
-
- end subroutine get_lrbt_slices
-
-!
-!--------------------------------------------------------------------------------------------------
-!
-
- integer function get_slice_number(ichunk,ixi,ieta,nproc_xi,nproc_eta)
-
- implicit none
-
- integer :: ichunk, ixi, ieta, nproc_xi, nproc_eta
-
- get_slice_number = ichunk*nproc_xi*nproc_eta+ieta*nproc_xi+ixi
-
- end function get_slice_number
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_prem.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_prem.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_prem.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,627 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-!
-! PREM [Dziewonski and Anderson, 1981].
-!
-! A. M. Dziewonski and D. L. Anderson.
-! Preliminary reference Earth model.
-! Phys. Earth Planet. Inter., 25:297–356, 1981.
-!
-! Isotropic (iso) and transversely isotropic (aniso) version of the
-! spherically symmetric Preliminary Reference Earth Model
-!
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_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-dimensionalized 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 in model_prem_iso()')
- !
- !--- 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 in model_prem_iso()')
- !
- !--- 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 in model_prem_iso()')
- !
- !--- 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 in model_prem_iso()')
- !
- !--- 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 in model_prem_iso()')
- !
- !--- 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 in model_prem_iso()')
- 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
- ! density/velocity from mantle just below moho
- drhodr=0.6924d0
- rho=2.6910d0+0.6924d0*x
- vp=4.1875d0+3.9382d0*x
- vs=2.1519d0+2.3481d0*x
- ! shear attenuation for R80 to surface
- 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 model_prem_iso
-
-!
-!=====================================================================
-!
-
- subroutine model_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-dimensionalized 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 in model_prem_aniso()')
-!
-!--- 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 in model_prem_aniso()')
-!
-!--- D" at the base of the mantle
-!
- else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
- if(idoubling /= IFLAG_MANTLE_NORMAL) then
- print*,'error dprime point:',r, RCMB,RTOPDDOUBLEPRIME,idoubling,IFLAG_MANTLE_NORMAL
- call exit_MPI(myrank,'wrong doubling flag for D" point in model_prem_aniso()')
- endif
-!
-!--- 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 in model_prem_aniso()')
-
-!
-!--- 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 in model_prem_aniso()')
-
-!
-!--- 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 in model_prem_aniso()')
-
- 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 model_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-dimensionalized 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 in prem_display_outer_core()')
-
-!
-!--- 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
-
- ! compute real physical radius in meters
- r = x * R_EARTH
-
- ! calculates density according to radius
- 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/model_s20rts.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_s20rts.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_s20rts.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,515 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! S20rts
-!
-! 3D mantle model S20RTS [Ritsema et al., 1999]
-!
-! Note that S20RTS uses transversely isotropic PREM as a background
-! model, and that we use the PREM radial attenuation model when ATTENUATION is incorporated.
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_s20rts_broadcast(myrank,S20RTS_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
-! model_s20rts_variables s20rts
- type model_s20rts_variables
- sequence
- double precision dvs_a(0:NK_20,0:NS_20,0:NS_20)
- double precision dvs_b(0:NK_20,0:NS_20,0:NS_20)
- double precision dvp_a(0:NK_20,0:NS_20,0:NS_20)
- double precision dvp_b(0:NK_20,0:NS_20,0:NS_20)
- double precision spknt(NK_20+1)
- double precision qq0(NK_20+1,NK_20+1)
- double precision qq(3,NK_20+1,NK_20+1)
- end type model_s20rts_variables
-
- type (model_s20rts_variables) S20RTS_V
-! model_s20rts_variables
-
- integer :: myrank
- integer :: ier
-
- ! the variables read are declared and stored in structure S20RTS_V
- if(myrank == 0) call read_model_s20rts(S20RTS_V)
-
- ! broadcast the information read on the master to the nodes
- call MPI_BCAST(S20RTS_V%dvs_a,(NK_20+1)*(NS_20+1)*(NS_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S20RTS_V%dvs_b,(NK_20+1)*(NS_20+1)*(NS_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S20RTS_V%dvp_a,(NK_20+1)*(NS_20+1)*(NS_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S20RTS_V%dvp_b,(NK_20+1)*(NS_20+1)*(NS_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S20RTS_V%spknt,NK_20+1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S20RTS_V%qq0,(NK_20+1)*(NK_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S20RTS_V%qq,3*(NK_20+1)*(NK_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- end subroutine model_s20rts_broadcast
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_model_s20rts(S20RTS_V)
-
- implicit none
-
- include "constants.h"
-
-! model_s20rts_variables
- type model_s20rts_variables
- sequence
- double precision dvs_a(0:NK_20,0:NS_20,0:NS_20)
- double precision dvs_b(0:NK_20,0:NS_20,0:NS_20)
- double precision dvp_a(0:NK_20,0:NS_20,0:NS_20)
- double precision dvp_b(0:NK_20,0:NS_20,0:NS_20)
- double precision spknt(NK_20+1)
- double precision qq0(NK_20+1,NK_20+1)
- double precision qq(3,NK_20+1,NK_20+1)
- end type model_s20rts_variables
-
- type (model_s20rts_variables) S20RTS_V
-! model_s20rts_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_20
- do l=0,NS_20
- read(10,*) S20RTS_V%dvs_a(k,l,0),(S20RTS_V%dvs_a(k,l,m),S20RTS_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_20
- do l=0,12
- read(10,*) S20RTS_V%dvp_a(k,l,0),(S20RTS_V%dvp_a(k,l,m),S20RTS_V%dvp_b(k,l,m),m=1,l)
- enddo
- do l=13,NS_20
- S20RTS_V%dvp_a(k,l,0) = 0.0d0
- do m=1,l
- S20RTS_V%dvp_a(k,l,m) = 0.0d0
- S20RTS_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 s20rts_splhsetup(S20RTS_V)
-
- end subroutine read_model_s20rts
-
-!---------------------------
-
- subroutine mantle_s20rts(radius,theta,phi,dvs,dvp,drho,S20RTS_V)
-
- implicit none
-
- include "constants.h"
-
-! model_s20rts_variables
- type model_s20rts_variables
- sequence
- double precision dvs_a(0:NK_20,0:NS_20,0:NS_20)
- double precision dvs_b(0:NK_20,0:NS_20,0:NS_20)
- double precision dvp_a(0:NK_20,0:NS_20,0:NS_20)
- double precision dvp_b(0:NK_20,0:NS_20,0:NS_20)
- double precision spknt(NK_20+1)
- double precision qq0(NK_20+1,NK_20+1)
- double precision qq(3,NK_20+1,NK_20+1)
- end type model_s20rts_variables
-
- type (model_s20rts_variables) S20RTS_V
-! model_s20rts_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 s20rts_rsple,radial_basis(0:NK_20)
- double precision sint,cost,x(2*NS_20+1),dx(2*NS_20+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_20
- radial_basis(k)=s20rts_rsple(1,NK_20+1,S20RTS_V%spknt(1),S20RTS_V%qq0(1,NK_20+1-k),S20RTS_V%qq(1,1,NK_20+1-k),xr)
- enddo
-
- do l=0,NS_20
- 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_20
- dvs_alm=dvs_alm+radial_basis(k)*S20RTS_V%dvs_a(k,l,0)
- dvp_alm=dvp_alm+radial_basis(k)*S20RTS_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_20
- dvs_alm=dvs_alm+radial_basis(k)*S20RTS_V%dvs_a(k,l,m)
- dvp_alm=dvp_alm+radial_basis(k)*S20RTS_V%dvp_a(k,l,m)
- dvs_blm=dvs_blm+radial_basis(k)*S20RTS_V%dvs_b(k,l,m)
- dvp_blm=dvp_blm+radial_basis(k)*S20RTS_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_s20rts
-
-!----------------------------------
-
- subroutine s20rts_splhsetup(S20RTS_V)!!!!!!!!!!!!!!(spknt,qq0,qq)
-
- implicit none
- include "constants.h"
-
-!!!!!!!!!!!!!!!!!!! double precision spknt(NK_20+1),qq0(NK_20+1,NK_20+1),qq(3,NK_20+1,NK_20+1)
-
-! model_s20rts_variables
- type model_s20rts_variables
- sequence
- double precision dvs_a(0:NK_20,0:NS_20,0:NS_20)
- double precision dvs_b(0:NK_20,0:NS_20,0:NS_20)
- double precision dvp_a(0:NK_20,0:NS_20,0:NS_20)
- double precision dvp_b(0:NK_20,0:NS_20,0:NS_20)
- double precision spknt(NK_20+1)
- double precision qq0(NK_20+1,NK_20+1)
- double precision qq(3,NK_20+1,NK_20+1)
- end type model_s20rts_variables
-
- type (model_s20rts_variables) S20RTS_V
-! model_s20rts_variables
-
-
- integer i,j
- double precision qqwk(3,NK_20+1)
-
- S20RTS_V%spknt(1) = -1.00000d0
- S20RTS_V%spknt(2) = -0.78631d0
- S20RTS_V%spknt(3) = -0.59207d0
- S20RTS_V%spknt(4) = -0.41550d0
- S20RTS_V%spknt(5) = -0.25499d0
- S20RTS_V%spknt(6) = -0.10909d0
- S20RTS_V%spknt(7) = 0.02353d0
- S20RTS_V%spknt(8) = 0.14409d0
- S20RTS_V%spknt(9) = 0.25367d0
- S20RTS_V%spknt(10) = 0.35329d0
- S20RTS_V%spknt(11) = 0.44384d0
- S20RTS_V%spknt(12) = 0.52615d0
- S20RTS_V%spknt(13) = 0.60097d0
- S20RTS_V%spknt(14) = 0.66899d0
- S20RTS_V%spknt(15) = 0.73081d0
- S20RTS_V%spknt(16) = 0.78701d0
- S20RTS_V%spknt(17) = 0.83810d0
- S20RTS_V%spknt(18) = 0.88454d0
- S20RTS_V%spknt(19) = 0.92675d0
- S20RTS_V%spknt(20) = 0.96512d0
- S20RTS_V%spknt(21) = 1.00000d0
-
- do i=1,NK_20+1
- do j=1,NK_20+1
- if(i == j) then
- S20RTS_V%qq0(j,i)=1.0d0
- else
- S20RTS_V%qq0(j,i)=0.0d0
- endif
- enddo
- enddo
- do i=1,NK_20+1
- call s20rts_rspln(1,NK_20+1,S20RTS_V%spknt(1),S20RTS_V%qq0(1,i),S20RTS_V%qq(1,1,i),qqwk(1,1))
- enddo
-
- end subroutine s20rts_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 s20rts_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)
- S20RTS_RSPLE=Y(I)+H*(Q(1,I)+H*(Q(2,I)+H*Q(3,I)))
-
- end function s20rts_rsple
-
-!----------------------------------
-
- subroutine s20rts_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 s20rts_rspln
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_s362ani.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_s362ani.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_s362ani.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1990 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! S362ani
-!
-! A global shear-wave speed model developed by Kustowski et al. [2006].
-!
-! In this model, radial anisotropy is confined to the uppermost mantle.
-! The model (and the corresponding mesh) incorporate
-! tomography on the 650~km and 410~km discontinuities in the 1D reference model REF.
-!
-! s362wmani: A version of S362ANI with anisotropy allowed throughout the mantle.
-!
-! s362ani_prem: A version of S362ANI calculated using PREM as the 1D reference model
-!
-! s29ea: A global model with higher resolution in the upper mantle beneath Eurasia
-! calculated using REF as the 1D reference model.
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_s362ani_broadcast(myrank,THREE_D_MODEL,numker,numhpa,ihpa,&
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
- xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
- integer THREE_D_MODEL
-
-! used for 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
- 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=40) varstr(maxker)
- character(len=80) refmdl
-
- integer :: myrank
- integer :: ier
-
- ! master process
- 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)
-
-
- end subroutine model_s362ani_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- 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 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 splcon(xlat,xlon,nver,verlat,verlon,verrad,ncon,icon,con)
-
- implicit none
-
- integer :: ncon,nver
-
-!daniel: original
-! integer icon(1)
-!
-! real(kind=4) verlat(1)
-! real(kind=4) verlon(1)
-! real(kind=4) verrad(1)
-! real(kind=4) con(1)
-
-!daniel: avoiding out-of-bounds errors
- real(kind=4) verlat(nver)
- real(kind=4) verlon(nver)
- real(kind=4) verrad(nver)
-
- integer icon(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 :: iver
- 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 model_s362ani_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
-
-! -------------------------------------
- vsv3drel = 0.
- vsh3drel = 0.
-
- 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)
-!daniel
-! call splcon(y,x,numcof,xlaspl(1,ihpa), &
-! xlospl(1,ihpa),radspl(1,ihpa), &
-! nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
-
- call splcon(y,x,numcof,xlaspl(1:numcof,ihpa), &
- xlospl(1:numcof,ihpa),radspl(1:numcof,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 model_s362ani_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)
-
-!daniel
-! call splcon(y,x,numcof,xlaspl(1,ihpa), &
-! xlospl(1,ihpa),radspl(1,ihpa), &
-! nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
-
- call splcon(y,x,numcof,xlaspl(1:numcof,ihpa), &
- xlospl(1:numcof,ihpa),radspl(1:numcof,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) WK1(LMAX+1),WK2(LMAX+1),WK3(LMAX+1)
- real(kind=4) XLAT,XLON
- real(kind=4) Y(1) !! Y should go at least from 1 to fac(LMAX)
-
- 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
-
- ! index L goes from 0 to LMAX
- L=IL1-1
- !CALL legndr(THETA,L,L,WK1,WK2,WK3)
- CALL legndr(THETA,L,L,WK1(1:L+1),WK2(1:L+1),WK3(1:L+1)) !! see legndr(): WK1,WK2,WK3 should go from 1 to L+1
-
- FAC=(1.,0.)
- DFAC=CEXP(CMPLX(0.,PHI))
-
- ! loops over M
- do IM=1,IL1
- ! index IM goes maximum from 1 to LMAX+1
- 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) !! X, XP, XCOSEC should go from 1 to M+1
-
- 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
-
- real(kind=4) :: X(M+1),XP(M+1),XCOSEC(M+1) !! X, XP, XCOSEC should go from 1 to M+1
-
-
-!!!!!! 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/model_s40rts.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_s40rts.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_s40rts.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,520 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! S40rts
-!
-! 3D mantle model S40RTS [Ritsema et al., 2010]
-!
-! Note that S40RTS uses transversely isotropic PREM as a background
-! model, and that we use the PREM radial attenuation model when ATTENUATION is incorporated.
-!
-! reference:
-! J. Ritsema, A. Deuss, H.J. van Heijst and J.H. Woodhouse, 2010.
-! S40RTS: a degree-40 shear-velocity model for the mantle from new Rayleigh wave dispersion,
-! teleseismic traveltime and normal-mode splitting function measurements.
-! Geophys. J. Int., DOI: 10.1111/j.1365-246X.2010.04884.x
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_s40rts_broadcast(myrank,S40RTS_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
-! model_s40rts_variables s40rts
- type model_s40rts_variables
- sequence
- double precision dvs_a(0:NK_20,0:NS_40,0:NS_40)
- double precision dvs_b(0:NK_20,0:NS_40,0:NS_40)
- double precision dvp_a(0:NK_20,0:NS_40,0:NS_40)
- double precision dvp_b(0:NK_20,0:NS_40,0:NS_40)
- double precision spknt(NK_20+1)
- double precision qq0(NK_20+1,NK_20+1)
- double precision qq(3,NK_20+1,NK_20+1)
- end type model_s40rts_variables
-
- type (model_s40rts_variables) S40RTS_V
-! model_s40rts_variables
-
- integer :: myrank
- integer :: ier
- ! the variables read are declared and stored in structure S40RTS_V
- if(myrank == 0) call read_model_s40rts(S40RTS_V)
-
- ! broadcast the information read on the master to the nodes
- call MPI_BCAST(S40RTS_V%dvs_a,(NK_20+1)*(NS_40+1)*(NS_40+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S40RTS_V%dvs_b,(NK_20+1)*(NS_40+1)*(NS_40+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S40RTS_V%dvp_a,(NK_20+1)*(NS_40+1)*(NS_40+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S40RTS_V%dvp_b,(NK_20+1)*(NS_40+1)*(NS_40+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S40RTS_V%spknt,NK_20+1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S40RTS_V%qq0,(NK_20+1)*(NK_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(S40RTS_V%qq,3*(NK_20+1)*(NK_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- end subroutine model_s40rts_broadcast
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_model_s40rts(S40RTS_V)
-
- implicit none
-
- include "constants.h"
-
-! model_s40rts_variables
- type model_s40rts_variables
- sequence
- double precision dvs_a(0:NK_20,0:NS_40,0:NS_40)
- double precision dvs_b(0:NK_20,0:NS_40,0:NS_40)
- double precision dvp_a(0:NK_20,0:NS_40,0:NS_40)
- double precision dvp_b(0:NK_20,0:NS_40,0:NS_40)
- double precision spknt(NK_20+1)
- double precision qq0(NK_20+1,NK_20+1)
- double precision qq(3,NK_20+1,NK_20+1)
- end type model_s40rts_variables
-
- type (model_s40rts_variables) S40RTS_V
-! model_s40rts_variables
-
- integer k,l,m
-
- character(len=150) S40RTS, P12
- call get_value_string(S40RTS, 'model.S40RTS', 'DATA/s40rts/S40RTS.dat')
- call get_value_string(P12, 'model.P12', 'DATA/s20rts/P12.dat') !model P12 is in s20rts data directory
-
-! S40RTS degree 20 S model from Ritsema
- open(unit=10,file=S40RTS,status='old',action='read')
- do k=0,NK_20
- do l=0,NS_40
- read(10,*) S40RTS_V%dvs_a(k,l,0),(S40RTS_V%dvs_a(k,l,m),S40RTS_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_20
- do l=0,12
- read(10,*) S40RTS_V%dvp_a(k,l,0),(S40RTS_V%dvp_a(k,l,m),S40RTS_V%dvp_b(k,l,m),m=1,l)
- enddo
- do l=13,NS_40
- S40RTS_V%dvp_a(k,l,0) = 0.0d0
- do m=1,l
- S40RTS_V%dvp_a(k,l,m) = 0.0d0
- S40RTS_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 s40rts_splhsetup(S40RTS_V)
-
- end subroutine read_model_s40rts
-
-!---------------------------
-
- subroutine mantle_s40rts(radius,theta,phi,dvs,dvp,drho,S40RTS_V)
-
- implicit none
-
- include "constants.h"
-
-! model_s40rts_variables
- type model_s40rts_variables
- sequence
- double precision dvs_a(0:NK_20,0:NS_40,0:NS_40)
- double precision dvs_b(0:NK_20,0:NS_40,0:NS_40)
- double precision dvp_a(0:NK_20,0:NS_40,0:NS_40)
- double precision dvp_b(0:NK_20,0:NS_40,0:NS_40)
- double precision spknt(NK_20+1)
- double precision qq0(NK_20+1,NK_20+1)
- double precision qq(3,NK_20+1,NK_20+1)
- end type model_s40rts_variables
-
- type (model_s40rts_variables) S40RTS_V
-! model_s40rts_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 s40rts_rsple,radial_basis(0:NK_20)
- double precision sint,cost,x(2*NS_40+1),dx(2*NS_40+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)
- if(xr > 1.0) print *,'xr > 1.0'
- if(xr < -1.0) print *,'xr < -1.0'
- do k=0,NK_20
- radial_basis(k)=s40rts_rsple(1,NK_20+1,S40RTS_V%spknt(1),S40RTS_V%qq0(1,NK_20+1-k),S40RTS_V%qq(1,1,NK_20+1-k),xr)
- enddo
-
- do l=0,NS_40
- 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_20
- dvs_alm=dvs_alm+radial_basis(k)*S40RTS_V%dvs_a(k,l,0)
- dvp_alm=dvp_alm+radial_basis(k)*S40RTS_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_20
- dvs_alm=dvs_alm+radial_basis(k)*S40RTS_V%dvs_a(k,l,m)
- dvp_alm=dvp_alm+radial_basis(k)*S40RTS_V%dvp_a(k,l,m)
- dvs_blm=dvs_blm+radial_basis(k)*S40RTS_V%dvs_b(k,l,m)
- dvp_blm=dvp_blm+radial_basis(k)*S40RTS_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_s40rts
-
-!----------------------------------
-
- subroutine s40rts_splhsetup(S40RTS_V)!!!!!!!!!!!!!!(spknt,qq0,qq)
-
- implicit none
- include "constants.h"
-
-!!!!!!!!!!!!!!!!!!! double precision spknt(NK_20+1),qq0(NK_20+1,NK_20+1),qq(3,NK_20+1,NK_20+1)
-
-! model_s40rts_variables
- type model_s40rts_variables
- sequence
- double precision dvs_a(0:NK_20,0:NS_40,0:NS_40)
- double precision dvs_b(0:NK_20,0:NS_40,0:NS_40)
- double precision dvp_a(0:NK_20,0:NS_40,0:NS_40)
- double precision dvp_b(0:NK_20,0:NS_40,0:NS_40)
- double precision spknt(NK_20+1)
- double precision qq0(NK_20+1,NK_20+1)
- double precision qq(3,NK_20+1,NK_20+1)
- end type model_s40rts_variables
-
- type (model_s40rts_variables) S40RTS_V
-! model_s40rts_variables
-
-
- integer i,j
- double precision qqwk(3,NK_20+1)
-
- S40RTS_V%spknt(1) = -1.00000d0
- S40RTS_V%spknt(2) = -0.78631d0
- S40RTS_V%spknt(3) = -0.59207d0
- S40RTS_V%spknt(4) = -0.41550d0
- S40RTS_V%spknt(5) = -0.25499d0
- S40RTS_V%spknt(6) = -0.10909d0
- S40RTS_V%spknt(7) = 0.02353d0
- S40RTS_V%spknt(8) = 0.14409d0
- S40RTS_V%spknt(9) = 0.25367d0
- S40RTS_V%spknt(10) = 0.35329d0
- S40RTS_V%spknt(11) = 0.44384d0
- S40RTS_V%spknt(12) = 0.52615d0
- S40RTS_V%spknt(13) = 0.60097d0
- S40RTS_V%spknt(14) = 0.66899d0
- S40RTS_V%spknt(15) = 0.73081d0
- S40RTS_V%spknt(16) = 0.78701d0
- S40RTS_V%spknt(17) = 0.83810d0
- S40RTS_V%spknt(18) = 0.88454d0
- S40RTS_V%spknt(19) = 0.92675d0
- S40RTS_V%spknt(20) = 0.96512d0
- S40RTS_V%spknt(21) = 1.00000d0
-
- do i=1,NK_20+1
- do j=1,NK_20+1
- if(i == j) then
- S40RTS_V%qq0(j,i)=1.0d0
- else
- S40RTS_V%qq0(j,i)=0.0d0
- endif
- enddo
- enddo
- do i=1,NK_20+1
- call s40rts_rspln(1,NK_20+1,S40RTS_V%spknt(1),S40RTS_V%qq0(1,i),S40RTS_V%qq(1,1,i),qqwk(1,1))
- enddo
-
- end subroutine s40rts_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 s40rts_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)
- S40RTS_RSPLE=Y(I)+H*(Q(1,I)+H*(Q(2,I)+H*Q(3,I)))
-
- end function s40rts_rsple
-
-!----------------------------------
-
- subroutine s40rts_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 s40rts_rspln
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea1d.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea1d.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1182 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! SEA 1D
-!
-! used as 1-D reference model for SEA 99, Vs model by Lebedev & Nolet 2003
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_sea1d_broadcast(CRUSTAL, SEA1DM_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
-
- ! model_sea1d_variables
- type model_sea1d_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 model_sea1d_variables
-
- type (model_sea1d_variables) SEA1DM_V
- ! model_sea1d_variables
-
- logical :: CRUSTAL
-
- ! all processes will define same parameters
- call define_model_sea1d(CRUSTAL, SEA1DM_V)
-
- end subroutine model_sea1d_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine model_sea1d(x,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
-
- implicit none
-
- include "constants.h"
-
-! model_sea1d_variables
- type model_sea1d_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 model_sea1d_variables
-
- type (model_sea1d_variables) SEA1DM_V
-! model_sea1d_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"
-
-! model_sea1d_variables
- type model_sea1d_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 model_sea1d_variables
-
- type (model_sea1d_variables) SEA1DM_V
-! model_sea1d_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 (SUPPRESS_CRUSTAL_MESH .or. 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/model_sea99_s.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea99_s.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea99_s.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,252 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! SEA 99 model
-!
-! contains relative Vs anomalies dVs/Vs from
-! SV-velocity model for SE Asia - W Pacific.
-!
-! defined for:
-! -20.00 45.00 -- min, max latitude
-! 95.00 160.00 -- min, max longitude
-! and depths between 6 km to 860 km
-!
-! computed by Lebedev and Nolet in 1999, to come out in JGR in 2003.
-! reference period: 50 s.
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_sea99_s_broadcast(myrank,SEA99M_V)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
- ! model_sea99_s_variables
- type model_sea99_s_variables
- sequence
- double precision :: sea99_vs(100,100,100)
- double precision :: sea99_depth(100)
- double precision :: sea99_ddeg
- double precision :: alatmin
- double precision :: alatmax
- double precision :: alonmin
- double precision :: alonmax
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_sea99_s_variables
-
- type (model_sea99_s_variables) SEA99M_V
- ! model_sea99_s_variables
-
- integer :: myrank
- integer :: ier
-
- 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)
-
- end subroutine model_sea99_s_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_sea99_s_model(SEA99M_V)
-
- implicit none
-
- include "constants.h"
-
- ! model_sea99_s_variables
- type model_sea99_s_variables
- sequence
- double precision :: sea99_vs(100,100,100)
- double precision :: sea99_depth(100)
- double precision :: sea99_ddeg
- double precision :: alatmin
- double precision :: alatmax
- double precision :: alonmin
- double precision :: alonmax
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_sea99_s_variables
-
- type (model_sea99_s_variables) SEA99M_V
- ! model_sea99_s_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 /= nint((SEA99M_V%alatmax-SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg)+1) then
- stop 'alatmin,alatmax,sea99_nlat'
- endif
- if (SEA99M_V%sea99_nlon /= 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 model_sea99_s(radius,theta,phi,dvs,SEA99M_V)
-
-! returns Vs perturbation (dvs) for given position r/theta/phi
-
- implicit none
-
- include "constants.h"
-
- ! model_sea99_s_variables
- type model_sea99_s_variables
- sequence
- double precision :: sea99_vs(100,100,100)
- double precision :: sea99_depth(100)
- double precision :: sea99_ddeg
- double precision :: alatmin
- double precision :: alatmax
- double precision :: alonmin
- double precision :: alonmax
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_sea99_s_variables
-
- type (model_sea99_s_variables) SEA99M_V
- ! model_sea99_s_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)
-
- ! initializes
- dvs = 0.d0
-
- id1 = 0
- xd1 = 0
-
- !----------------------- depth in the model ------------------
- dep=R_EARTH_KM*(R_UNIT_SPHERE - radius)
- 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))
- exit
- endif
- enddo
- endif
-
- !----------------------- value at a point ---------------------
- !----- approximate interpolation, OK for the (dense) 1-degree sampling ------
-
- ! latitude / longitude in degree
- pla = 90.0d0 - theta/DEGREES_TO_RADIANS
- plo = phi/DEGREES_TO_RADIANS
-
- ! model defined for:
- ! -20.00 45.00 -- min, max latitude
- ! 95.00 160.00 -- min, max longitude
- ! checks range
- if( pla < SEA99M_V%alatmin .or. pla > SEA99M_V%alatmax &
- .or. plo < SEA99M_V%alonmin .or. plo > SEA99M_V%alonmax ) return
-
- ! array indices
- 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
-
- ! checks perturbation
- if(dvs > 1.d0) dvs = 0.0d0
-
- end subroutine model_sea99_s
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/model_topo_bathy.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_topo_bathy.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_topo_bathy.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,195 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!--------------------------------------------------------------------------------------------------
-! ETOPO
-!
-! Global Gridded Elevation Data
-!
-! by default (constants.h), it uses a smoothed ETOPO 4 dataset
-!--------------------------------------------------------------------------------------------------
-
-
- subroutine model_topo_bathy_broadcast(myrank,ibathy_topo)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
- ! bathymetry and topography: use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
- integer :: myrank
- integer :: ier
-
- 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)
-
- end subroutine model_topo_bathy_broadcast
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- 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,ier
-
- call get_value_string(topo_bathy_file, 'model.topoBathy.PATHNAME_TOPO_FILE', PATHNAME_TOPO_FILE)
-
- ! reads in topography values from file
- open(unit=13,file=trim(topo_bathy_file),status='old',action='read',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening:',trim(topo_bathy_file)
- call exit_mpi(0,'error opening topography data file')
- endif
- ! reads in topography array
- do itopo_y=1,NY_BATHY
- do itopo_x=1,NX_BATHY
- read(13,*) ibathy_topo(itopo_x,itopo_y)
- enddo
- enddo
- close(13)
-
-
- ! note: we check the limits after reading in the data. this seems to perform sligthly faster
- ! however, reading ETOPO1.xyz will take ~ 2m 1.2s for a single process
-
- ! imposes limits
- if( USE_MAXIMUM_HEIGHT_TOPO .or. USE_MAXIMUM_DEPTH_OCEANS ) then
- do itopo_y=1,NY_BATHY
- do itopo_x=1,NX_BATHY
-
- ! 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
-
- endif
-
- end subroutine read_topo_bathy_file
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- 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
- double precision:: lon_corner,lat_corner,ratio_lon,ratio_lat
-
- 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
-
-! Use bilinear interpolation rather nearest point interpolation
-! convert integer value to double precision
- ! value = dble(ibathy_topo(iel1,iadd1))
-
- lon_corner=iel1*samples_per_degree_topo
- lat_corner=90.d0-iadd1*samples_per_degree_topo
-
- ratio_lon = (xlo-lon_corner)/samples_per_degree_topo
- ratio_lat = (xlat-lat_corner)/samples_per_degree_topo
-
- if(ratio_lon<0.0) ratio_lon=0.0
- if(ratio_lon>1.0) ratio_lon=1.0
- if(ratio_lat<0.0) ratio_lat=0.0
- if(ratio_lat>1.0) ratio_lat=1.0
-
-! convert integer value to double precision
- if( iadd1 <= NY_BATHY-1 .and. iel1 <= NX_BATHY-1 ) then
- ! interpolates for points within boundaries
- value = dble(ibathy_topo(iel1,iadd1))*(1-ratio_lon)*(1.-ratio_lat) &
- + dble(ibathy_topo(iel1+1,iadd1))*ratio_lon*(1.-ratio_lat) &
- + dble(ibathy_topo(iel1+1,iadd1+1))*ratio_lon*ratio_lat &
- + dble(ibathy_topo(iel1,iadd1+1))*(1.-ratio_lon)*ratio_lat
- else if( iadd1 <= NY_BATHY-1 .and. iel1 == NX_BATHY ) then
- ! interpolates for points on longitude border
- value = dble(ibathy_topo(iel1,iadd1))*(1-ratio_lon)*(1.-ratio_lat) &
- + dble(ibathy_topo(1,iadd1))*ratio_lon*(1.-ratio_lat) &
- + dble(ibathy_topo(1,iadd1+1))*ratio_lon*ratio_lat &
- + dble(ibathy_topo(iel1,iadd1+1))*(1.-ratio_lon)*ratio_lat
- else
- ! for points on latitude boundaries
- value = dble(ibathy_topo(iel1,iadd1))
- endif
-
- end subroutine get_topo_bathy
-
-! -------------------------------------------
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/moho_stretching.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/moho_stretching.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/moho_stretching.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,907 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
- subroutine moho_stretching_honor_crust(myrank,xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
-
-! stretching the moho according to the crust 2.0
-! input: myrank, xelm, yelm, zelm, RMOHO_FICTITIOUS_IN_MESHER R220,RMIDDLE_CRUST, CM_V
-! Dec, 30, 2009
-
- implicit none
-
- include "constants.h"
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
- double precision R220,RMIDDLE_CRUST
- double precision RMOHO_FICTITIOUS_IN_MESHER
- integer :: myrank
- logical :: elem_in_crust,elem_in_mantle
-
- ! local parameters
- integer:: ia,count_crust,count_mantle
- double precision:: r,theta,phi,lat,lon
- double precision:: vpc,vsc,rhoc,moho,elevation,gamma
- logical:: found_crust
-
- double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
- double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
- !double precision :: stretch_factor
- double precision :: x,y,z
- double precision :: R_moho,R_middlecrust
-
- ! radii for stretching criteria
- R_moho = RMOHO_FICTITIOUS_IN_MESHER/R_EARTH
- R_middlecrust = RMIDDLE_CRUST/R_EARTH
-
- ! loops over element's anchor points
- count_crust = 0
- count_mantle = 0
- do ia = 1,NGNOD
- x = xelm(ia)
- y = yelm(ia)
- z = zelm(ia)
-
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
- call reduce(theta,phi)
-
- lat = 90.d0 - theta * RADIANS_TO_DEGREES
- lon = phi * RADIANS_TO_DEGREES
- if( lon > 180.d0 ) lon = lon - 360.0d0
-
- ! initializes
- moho = 0.d0
-
- ! gets smoothed moho depth
- call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
-
- ! checks moho depth
- if( abs(moho) < TINYVAL ) call exit_mpi(myrank,'error moho depth to honor')
-
- moho = ONE - moho
-
- ! checks if moho will be honored by elements
- !
- ! note: we will honor the moho only, if the moho depth is below R_moho (~35km)
- ! or above R_middlecrust (~15km). otherwise, the moho will be "interpolated"
- ! within the element
- if (moho < R_moho ) then
- ! actual moho below fictitious moho
- ! elements in second layer will stretch down to honor moho topography
-
- elevation = moho - R_moho
-
- if ( r >= R_moho ) then
- ! point above fictitious moho
- ! gamma ranges from 0 (point at surface) to 1 (point at fictitious moho depth)
- gamma = (( R_UNIT_SPHERE - r )/( R_UNIT_SPHERE - R_moho ))
- else
- ! point below fictitious moho
- ! gamma ranges from 0 (point at R220) to 1 (point at fictitious moho depth)
- gamma = (( r - R220/R_EARTH)/( R_moho - R220/R_EARTH))
-
- ! since not all GLL points are exactlly at R220, use a small
- ! tolerance for R220 detection, fix R220
- if (abs(gamma) < SMALLVAL) then
- gamma = 0.0d0
- end if
- end if
-
- if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
- call exit_MPI(myrank,'incorrect value of gamma for moho from crust 2.0')
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
-
- else if ( moho > R_middlecrust ) then
- ! moho above middle crust
- ! elements in first layer will squeeze into crust above moho
-
- elevation = moho - R_middlecrust
-
- if ( r > R_middlecrust ) then
- ! point above middle crust
- ! gamma ranges from 0 (point at surface) to 1 (point at middle crust depth)
- gamma = (R_UNIT_SPHERE-r)/(R_UNIT_SPHERE - R_middlecrust )
- else
- ! point below middle crust
- ! gamma ranges from 0 (point at R220) to 1 (point at middle crust depth)
- gamma = (r - R220/R_EARTH)/( R_middlecrust - R220/R_EARTH )
-
- ! since not all GLL points are exactlly at R220, use a small
- ! tolerance for R220 detection, fix R220
- if (abs(gamma) < SMALLVAL) then
- gamma = 0.0d0
- end if
- end if
-
- if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
- call exit_MPI(myrank,'incorrect value of gamma for moho from crust 2.0')
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
-
- end if
-
- ! counts corners in above moho
- ! note: uses a small tolerance
- if ( r >= 0.9999d0*moho ) then
- count_crust = count_crust + 1
- endif
- ! counts corners below moho
- ! again within a small tolerance
- if ( r <= 1.0001d0*moho ) then
- count_mantle = count_mantle + 1
- endif
-
- end do
-
- ! sets flag when all corners are above moho
- if( count_crust == NGNOD) then
- elem_in_crust = .true.
- end if
- ! sets flag when all corners are below moho
- if( count_mantle == NGNOD) then
- elem_in_mantle = .true.
- end if
-
- ! small stretch check: stretching should affect only points above R220
- if( r*R_EARTH < R220 ) then
- print*,'error moho stretching: ',r*R_EARTH,R220,moho*R_EARTH
- call exit_mpi(myrank,'incorrect moho stretching')
- endif
-
- end subroutine moho_stretching_honor_crust
-
-
-!
-!------------------------------------------------------------------------------------------------
-!
-
-
- subroutine moho_stretching_honor_crust_reg(myrank, &
- xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
-
-! regional routine: for REGIONAL_MOHO_MESH adaptations
-!
-! uses a 3-layer crust region
-!
-! stretching the moho according to the crust 2.0
-! input: myrank, xelm, yelm, zelm, RMOHO_FICTITIOUS_IN_MESHER R220,RMIDDLE_CRUST, CM_V
-! Dec, 30, 2009
-
- implicit none
-
- include "constants.h"
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
- double precision R220,RMIDDLE_CRUST
- double precision RMOHO_FICTITIOUS_IN_MESHER
- integer :: myrank
- logical :: elem_in_crust,elem_in_mantle
-
- ! local parameters
- integer:: ia,count_crust,count_mantle
- double precision:: r,theta,phi,lat,lon
- double precision:: vpc,vsc,rhoc,moho
- logical:: found_crust
-
- double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
- double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
- double precision :: x,y,z
-
- ! loops over element's anchor points
- count_crust = 0
- count_mantle = 0
- do ia = 1,NGNOD
-
- ! anchor point location
- x = xelm(ia)
- y = yelm(ia)
- z = zelm(ia)
-
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
- call reduce(theta,phi)
-
- lat = 90.d0 - theta * RADIANS_TO_DEGREES
- lon = phi * RADIANS_TO_DEGREES
- if( lon > 180.d0 ) lon = lon - 360.0d0
-
- ! initializes
- moho = 0.d0
-
- ! gets smoothed moho depth
- call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
-
- ! checks moho depth
- if( abs(moho) < TINYVAL ) call exit_mpi(myrank,'error moho depth to honor')
-
- moho = ONE - moho
-
- ! checks if moho will be honored by elements
- !
- ! note: we will honor the moho, if the moho depth is
- ! - above 15km
- ! - between 25km and 45km
- ! - below 60 km (in HONOR_DEEP_MOHO case)
- ! otherwise, the moho will be "interpolated" within the element
- if( HONOR_DEEP_MOHO) then
- call stretch_deep_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
- RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
- else
- call stretch_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
- RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
- endif
-
- ! counts corners in above moho
- ! note: uses a small tolerance
- if ( r >= 0.9999d0*moho ) then
- count_crust = count_crust + 1
- endif
- ! counts corners below moho
- ! again within a small tolerance
- if ( r <= 1.0001d0*moho ) then
- count_mantle = count_mantle + 1
- endif
-
- end do
-
- ! sets flag when all corners are above moho
- if( count_crust == NGNOD) then
- elem_in_crust = .true.
- end if
- ! sets flag when all corners are below moho
- if( count_mantle == NGNOD) then
- elem_in_mantle = .true.
- end if
-
- ! small stretch check: stretching should affect only points above R220
- if( r*R_EARTH < R220 ) then
- print*,'error moho stretching: ',r*R_EARTH,R220,moho*R_EARTH
- call exit_mpi(myrank,'incorrect moho stretching')
- endif
-
- end subroutine moho_stretching_honor_crust_reg
-
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine stretch_deep_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
- RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
-
-! honors deep moho (below 60 km), otherwise keeps the mesh boundary at r60 fixed
-
- implicit none
-
- include "constants.h"
-
- integer ia
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
- double precision :: x,y,z
-
- double precision :: r,moho,R220
- double precision :: RMIDDLE_CRUST
- double precision :: RMOHO_FICTITIOUS_IN_MESHER
-
- ! local parameters
- double precision :: elevation,gamma
- ! radii for stretching criteria
- double precision,parameter :: R15=6356000.d0/R_EARTH
- double precision,parameter :: R25=6346000.d0/R_EARTH
- double precision,parameter :: R30=6341000.d0/R_EARTH
- double precision,parameter :: R35=6336000.d0/R_EARTH
- double precision,parameter :: R40=6331000.d0/R_EARTH
- double precision,parameter :: R45=6326000.d0/R_EARTH
- double precision,parameter :: R50=6321000.d0/R_EARTH
- double precision,parameter :: R55=6316000.d0/R_EARTH
- double precision,parameter :: R60=6311000.d0/R_EARTH
-
- ! checks moho position: supposed to be at 60 km
- if( RMOHO_STRETCH_ADJUSTEMENT /= -20000.d0 ) &
- stop 'wrong moho stretch adjustement for stretch_deep_moho'
- if( RMOHO_FICTITIOUS_IN_MESHER/R_EARTH /= R60 ) &
- stop 'wrong moho depth '
- ! checks middle crust position: supposed to be bottom of first layer at 15 km
- if( RMIDDLE_CRUST/R_EARTH /= R15 ) &
- stop 'wrong middle crust depth'
-
- ! stretches mesh by moving point coordinates
- if ( moho < R25 .and. moho > R45 ) then
- ! moho between r25 and r45
-
- ! stretches mesh at r35 to moho depth
- elevation = moho - R35
- if ( r >=R35.and.r<R15) then
- gamma=((R15-r)/(R15-R35))
- else if ( r < R35 .and. r > R60 ) then
- gamma = (( r - R60)/( R35 - R60)) ! keeps r60 fixed
- if (abs(gamma)<SMALLVAL) then
- gamma=0.0d0
- end if
- else
- gamma=0.0d0
- end if
- if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
- stop 'incorrect value of gamma for moho from crust 2.0'
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
-
- else if ( moho < R45 ) then
- ! moho below r45
-
- ! moves mesh at r35 down to r45
- elevation = R45 - R35
- if ( r>= R35.and.r<R15) then
- gamma=((R15-r)/(R15-R35)) ! moves r35 down to r45
- else if ( r<R35 .and. r>R60 ) then
- gamma=((r-R60)/(R35-R60)) ! keeps r60 fixed
- if (abs(gamma)<SMALLVAL) then
- gamma=0.0d0
- end if
- else
- gamma=0.0d0
- end if
- if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
- stop 'incorrect value of gamma for moho from crust 2.0'
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
-
- ! add deep moho here
- if ( moho < R60) then
- ! moho below r60
-
- ! stretches mesh at r60 to moho
- elevation = moho - R60
- if ( r <R45.and. r >= R60) then
- gamma=(R45-r)/(R45-R60)
- else if (r<R60) then
- gamma=(r-R220/R_EARTH)/(R60-R220/R_EARTH)
- if (abs(gamma)<SMALLVAL) then
- gamma=0.0d0
- end if
- else
- gamma=0.0d0
- end if
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
- end if
-
- else if (moho > R25) then
- ! moho above r25
-
- ! moves mesh at r35 up to r25
- elevation = R25-R35
- if (r>=R35.and.r<R15) then
- gamma=((R15-r)/(R15-R35)) ! stretches r35 up to r25
- else if (r<R35 .and. r>R60 ) then
- gamma=(r-R60)/(R35-R60) ! keeps r60 fixed
- if (abs(gamma)<SMALLVAL) then
- gamma=0.0d0
- end if
- else
- gamma=0.0d0
- end if
- if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
- stop 'incorrect value of gamma for moho from crust 2.0'
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
-
- ! add shallow moho here
- if ( moho > R15 ) then
- ! moho above r15
-
- ! stretches mesh at r15 to moho depth
- elevation = moho-R15
- if (r>=R15) then
- gamma=(R_UNIT_SPHERE-r)/(R_UNIT_SPHERE-R15)
- else if (r<R15.and.R>R25) then
- gamma=(r-R25)/(R15-R25) ! keeps mesh at r25 fixed
- if (abs(gamma)<SMALLVAL) then
- gamma=0.0d0
- end if
- else
- gamma=0.0d0
- end if
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
- end if
- end if
-
- end subroutine stretch_deep_moho
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine stretch_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
- RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
-
-! honors shallow and middle depth moho, deep moho will be interpolated within elements
-! mesh will get stretched down to r220
-
- implicit none
-
- include "constants.h"
-
- integer ia
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
- double precision :: r,moho,R220
- double precision :: x,y,z
- double precision :: RMIDDLE_CRUST
- double precision :: RMOHO_FICTITIOUS_IN_MESHER
-
- ! local parameters
- double precision :: elevation,gamma
- ! radii for stretching criteria
- double precision,parameter :: R15=6356000.d0/R_EARTH
- double precision,parameter :: R25=6346000.d0/R_EARTH
- double precision,parameter :: R30=6341000.d0/R_EARTH
- double precision,parameter :: R35=6336000.d0/R_EARTH
- double precision,parameter :: R40=6331000.d0/R_EARTH
- double precision,parameter :: R45=6326000.d0/R_EARTH
- double precision,parameter :: R50=6321000.d0/R_EARTH
- double precision,parameter :: R55=6316000.d0/R_EARTH
- double precision,parameter :: R60=6311000.d0/R_EARTH
-
- ! checks moho position: supposed to be at 55 km
- if( RMOHO_STRETCH_ADJUSTEMENT /= -15000.d0 ) &
- stop 'wrong moho stretch adjustement for stretch_deep_moho'
- if( RMOHO_FICTITIOUS_IN_MESHER/R_EARTH /= R55 ) &
- stop 'wrong moho depth '
- ! checks middle crust position: supposed to be bottom of first layer at 15 km
- if( RMIDDLE_CRUST/R_EARTH /= R15 ) &
- stop 'wrong middle crust depth'
-
- ! moho between 25km and 45 km
- if ( moho < R25 .and. moho > R45 ) then
-
- elevation = moho - R35
- if ( r >=R35.and.r<R15) then
- gamma=((R15-r)/(R15-R35))
- else if ( r<R35.and.r>R220/R_EARTH) then
- gamma = ((r-R220/R_EARTH)/(R35-R220/R_EARTH))
- if (abs(gamma)<SMALLVAL) then
- gamma=0.0d0
- end if
- else
- gamma=0.0d0
- end if
- if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
- stop 'incorrect value of gamma for moho from crust 2.0'
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
-
- else if ( moho < R45 ) then
- ! moho below 45 km
-
- ! moves mesh at r35 down to r45
- elevation = R45 - R35
- if ( r>= R35.and.r<R15) then
- gamma=((R15-r)/(R15-R35))
- else if ( r<R35.and.r>R220/R_EARTH) then
- gamma=((r-R220/R_EARTH)/(R35-R220/R_EARTH))
- if (abs(gamma)<SMALLVAL) then
- gamma=0.0d0
- end if
- else
- gamma=0.0d0
- end if
- if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
- stop 'incorrect value of gamma for moho from crust 2.0'
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
-
- else if (moho > R25) then
- ! moho above 25km
-
- ! moves mesh at r35 up to r25
- elevation = R25-R35
- if (r>=R35.and.r<R15) then
- gamma=((R15-r)/(R15-R35))
- else if (r<R35.and.r>R220/R_EARTH) then
- gamma=(r-R220/R_EARTH)/(R35-R220/R_EARTH)
- if (abs(gamma)<SMALLVAL) then
- gamma=0.0d0
- end if
- else
- gamma=0.0d0
- end if
- if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
- stop 'incorrect value of gamma for moho from crust 2.0'
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
-
- ! add shallow moho here
- if ( moho >R15) then
- elevation = moho-R15
- if (r>=R15) then
- gamma=(R_UNIT_SPHERE-r)/(R_UNIT_SPHERE-R15)
- else if (r<R15.and.R>R25) then
- gamma=(r-R25)/(R15-R25)
- if (abs(gamma)<SMALLVAL) then
- gamma=0.0d0
- end if
- else
- gamma=0.0d0
- end if
-
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
- end if
- endif
-
- end subroutine stretch_moho
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
-
-! moves a point to a new location defined by gamma,elevation and r
- implicit none
-
- include "constants.h"
-
- integer ia
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
-
- double precision :: x,y,z
-
- double precision :: r,elevation,gamma
-
- ! local parameters
- double precision :: stretch_factor
-
- ! stretch factor
- ! offset will be gamma * elevation
- ! scaling cartesian coordinates xyz rather than spherical r/theta/phi involves division of offset by r
- stretch_factor = ONE + gamma * elevation/r
-
- ! new point location
- x = x * stretch_factor
- y = y * stretch_factor
- z = z * stretch_factor
-
- ! stores new point location
- xelm(ia) = x
- yelm(ia) = y
- zelm(ia) = z
-
- ! new radius
- r = dsqrt(xelm(ia)*xelm(ia) + yelm(ia)*yelm(ia) + zelm(ia)*zelm(ia))
-
- end subroutine move_point
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-! obsolete...
-!
-! 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/netlib_specfun_erf.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/netlib_specfun_erf.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/netlib_specfun_erf.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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/noise_tomography.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/noise_tomography.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/noise_tomography.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,653 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
-! subroutine for NOISE TOMOGRAPHY
-! chracterize noise statistics
-! for a given point (xcoord,ycoord,zcoord), specify the noise direction "normal_x/y/z_noise"
-! and noise distribution "mask_noise"
-! USERS need to modify this subroutine for their own noise characteristics
- subroutine noise_distribution_direction(xcoord_in,ycoord_in,zcoord_in, &
- normal_x_noise_out,normal_y_noise_out,normal_z_noise_out, &
- mask_noise_out)
- implicit none
- include "constants.h"
- ! input parameters
- real(kind=CUSTOM_REAL) :: xcoord_in,ycoord_in,zcoord_in
- ! output parameters
- real(kind=CUSTOM_REAL) :: normal_x_noise_out,normal_y_noise_out,normal_z_noise_out,mask_noise_out
- ! local parameters
- real(kind=CUSTOM_REAL) :: xcoord,ycoord,zcoord
-
-
- ! coordinates "x/y/zcoord_in" actually contain r theta phi, therefore convert back to x y z
- call rthetaphi_2_xyz(xcoord,ycoord,zcoord, xcoord_in,ycoord_in,zcoord_in)
- ! NOTE that all coordinates are non-dimensionalized in GLOBAL package!
- ! USERS are free to choose which set to use,
- ! either "r theta phi" (xcoord_in,ycoord_in,zcoord_in)
- ! or "x y z" (xcoord,ycoord,zcoord)
-
- !*****************************************************************************************************************
- !******************************** change your noise characteristics below ****************************************
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! noise direction
- ! here, the noise is assumed to be vertical
- normal_x_noise_out = xcoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
- normal_y_noise_out = ycoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
- normal_z_noise_out = zcoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! noise distribution
- ! here, the noise is assumed to be uniform
- mask_noise_out = 1.0
- !******************************** change your noise characteristics above ****************************************
- !*****************************************************************************************************************
-
- end subroutine noise_distribution_direction
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
-! subroutine for NOISE TOMOGRAPHY
-! read parameters
- subroutine read_parameters_noise(myrank,nrec,NSTEP,nmovie_points, &
- islice_selected_rec,xi_receiver,eta_receiver,gamma_receiver,nu, &
- noise_sourcearray,xigll,yigll,zigll,nspec_top, &
- NIT, ibool_crust_mantle, ibelm_top_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- irec_master_noise,normal_x_noise,normal_y_noise,normal_z_noise,mask_noise)
- implicit none
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
- include 'mpif.h'
- include "precision.h"
- ! input parameters
- integer :: myrank, nrec, NSTEP, nmovie_points, nspec_top, NIT
- integer, dimension(nrec) :: islice_selected_rec
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLY) :: yigll
- double precision, dimension(NGLLZ) :: zigll
- double precision, dimension(NDIM,NDIM,nrec) :: nu
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
- ! output parameters
- integer :: irec_master_noise
- real(kind=CUSTOM_REAL) :: noise_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NSTEP)
- real(kind=CUSTOM_REAL), dimension(nmovie_points) :: normal_x_noise,normal_y_noise,normal_z_noise,mask_noise
- ! local parameters
- integer :: ipoin, ispec2D, ispec, i, j, k, iglob, ios, ier
- real(kind=CUSTOM_REAL) :: normal_x_noise_out,normal_y_noise_out,normal_z_noise_out,mask_noise_out
- character(len=150) :: filename
- real(kind=CUSTOM_REAL), dimension(nmovie_points) :: &
- store_val_x,store_val_y,store_val_z, store_val_ux,store_val_uy,store_val_uz
- real(kind=CUSTOM_REAL), dimension(nmovie_points,0:NPROCTOT_VAL-1) :: &
- store_val_x_all,store_val_y_all,store_val_z_all, store_val_ux_all,store_val_uy_all,store_val_uz_all
-
-
- ! read master receiver ID -- the ID in DATA/STATIONS
- filename = 'NOISE_TOMOGRAPHY/'//'irec_master_noise'
- open(unit=IIN_NOISE,file=trim(filename),status='old',action='read',iostat=ios)
- if( ios /= 0) &
- call exit_MPI(myrank, 'file '//trim(filename)//' does NOT exist! This file contains the ID of the master receiver')
- read(IIN_NOISE,*,iostat=ios) irec_master_noise
- close(IIN_NOISE)
-
- if (myrank == 0) then
- open(unit=IOUT_NOISE,file='OUTPUT_FILES/irec_master_noise',status='unknown',action='write')
- WRITE(IOUT_NOISE,*) 'The master receiver is: (RECEIVER ID)', irec_master_noise
- close(IOUT_NOISE)
- endif
-
- ! compute source arrays for "ensemble forward source", which is source of "ensemble forward wavefield"
- if(myrank == islice_selected_rec(irec_master_noise) .OR. myrank == 0) then ! myrank == 0 is used for output only
- call compute_arrays_source_noise(myrank, &
- xi_receiver(irec_master_noise),eta_receiver(irec_master_noise),gamma_receiver(irec_master_noise), &
- nu(:,:,irec_master_noise),noise_sourcearray, xigll,yigll,zigll,NSTEP)
- endif
-
- ! noise distribution and noise direction
- ipoin = 0
- do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
- ispec = ibelm_top_crust_mantle(ispec2D)
-
- k = NGLLZ
-
- ! loop on all the points inside the element
- do j = 1,NGLLY,NIT
- do i = 1,NGLLX,NIT
- ipoin = ipoin + 1
- iglob = ibool_crust_mantle(i,j,k,ispec)
- ! this subroutine must be modified by USERS
- call noise_distribution_direction(xstore_crust_mantle(iglob), &
- ystore_crust_mantle(iglob),zstore_crust_mantle(iglob), &
- normal_x_noise_out,normal_y_noise_out,normal_z_noise_out, &
- mask_noise_out)
- normal_x_noise(ipoin) = normal_x_noise_out
- normal_y_noise(ipoin) = normal_y_noise_out
- normal_z_noise(ipoin) = normal_z_noise_out
- mask_noise(ipoin) = mask_noise_out
- enddo
- enddo
-
- enddo
-
- !!!BEGIN!!! save mask_noise for check, a file called "mask_noise" is saved in "./OUTPUT_FIELS/"
- ipoin = 0
- do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
- ispec = ibelm_top_crust_mantle(ispec2D)
- k = NGLLZ
- ! loop on all the points inside the element
- do j = 1,NGLLY,NIT
- do i = 1,NGLLX,NIT
- ipoin = ipoin + 1
- iglob = ibool_crust_mantle(i,j,k,ispec)
- store_val_x(ipoin) = xstore_crust_mantle(iglob)
- store_val_y(ipoin) = ystore_crust_mantle(iglob)
- store_val_z(ipoin) = zstore_crust_mantle(iglob)
- store_val_ux(ipoin) = mask_noise(ipoin)
- store_val_uy(ipoin) = mask_noise(ipoin)
- store_val_uz(ipoin) = mask_noise(ipoin)
- enddo
- enddo
- enddo
-
- ! gather info on master proc
- ispec = nmovie_points
- call MPI_GATHER(store_val_x,ispec,CUSTOM_MPI_TYPE,store_val_x_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_y,ispec,CUSTOM_MPI_TYPE,store_val_y_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_z,ispec,CUSTOM_MPI_TYPE,store_val_z_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_ux,ispec,CUSTOM_MPI_TYPE,store_val_ux_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_uy,ispec,CUSTOM_MPI_TYPE,store_val_uy_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_uz,ispec,CUSTOM_MPI_TYPE,store_val_uz_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
-
- ! save maks_noise data to disk in home directory
- ! this file can be viewed the same way as surface movie data (xcreate_movie_AVS_DX)
- ! create_movie_AVS_DX.f90 needs to be modified in order to do that,
- ! i.e., instead of showing the normal component, change it to either x, y or z component, or the norm.
- if(myrank == 0) then
- open(unit=IOUT_NOISE,file='OUTPUT_FILES/mask_noise',status='unknown',form='unformatted',action='write')
- write(IOUT_NOISE) store_val_x_all
- write(IOUT_NOISE) store_val_y_all
- write(IOUT_NOISE) store_val_z_all
- write(IOUT_NOISE) store_val_ux_all
- write(IOUT_NOISE) store_val_uy_all
- write(IOUT_NOISE) store_val_uz_all
- close(IOUT_NOISE)
- endif
- !!!END!!! save mask_noise for check, a file called "mask_noise" is saved in "./OUTPUT_FIELS/"
-
- end subroutine read_parameters_noise
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
-! subroutine for NOISE TOMOGRAPHY
-! check for consistency of the parameters
- subroutine check_parameters_noise(myrank,NOISE_TOMOGRAPHY,SIMULATION_TYPE,SAVE_FORWARD, &
- NUMBER_OF_RUNS, NUMBER_OF_THIS_RUN,ROTATE_SEISMOGRAMS_RT, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE, USE_BINARY_FOR_LARGE_FILE, &
- MOVIE_COARSE)
- implicit none
- include 'mpif.h'
- include "precision.h"
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
- ! input parameters
- integer :: myrank,NOISE_TOMOGRAPHY,SIMULATION_TYPE,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN
- logical :: SAVE_FORWARD,ROTATE_SEISMOGRAMS_RT,SAVE_ALL_SEISMOS_IN_ONE_FILE, USE_BINARY_FOR_LARGE_FILE,MOVIE_COARSE
- ! output parameters
- ! local parameters
-
-
- if (myrank == 0) then
- open(unit=IOUT_NOISE,file='OUTPUT_FILES/NOISE_SIMULATION',status='unknown',action='write')
- WRITE(IOUT_NOISE,*) '*******************************************************************************'
- WRITE(IOUT_NOISE,*) '*******************************************************************************'
- WRITE(IOUT_NOISE,*) 'WARNING!!!!!!!!!!!!'
- WRITE(IOUT_NOISE,*) 'You are running simulations using NOISE TOMOGRAPHY techniques.'
- WRITE(IOUT_NOISE,*) 'Please make sure you understand the procedures before you have a try.'
- WRITE(IOUT_NOISE,*) 'Displacements everywhere at the free surface are saved every timestep,'
- WRITE(IOUT_NOISE,*) 'so make sure that LOCAL_PATH in DATA/Par_file is not global.'
- WRITE(IOUT_NOISE,*) 'Otherwise the disk storage may be a serious issue, as is the speed of I/O.'
- WRITE(IOUT_NOISE,*) 'Also make sure that NO earthquakes are included,'
- WRITE(IOUT_NOISE,*) 'i.e., set moment tensor to be ZERO in CMTSOLUTION'
- WRITE(IOUT_NOISE,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
- WRITE(IOUT_NOISE,*) 'If you just want a regular EARTHQUAKE simulation,'
- WRITE(IOUT_NOISE,*) 'set NOISE_TOMOGRAPHY=0 in DATA/Par_file'
- WRITE(IOUT_NOISE,*) '*******************************************************************************'
- WRITE(IOUT_NOISE,*) '*******************************************************************************'
- close(IOUT_NOISE)
- endif
-
- if (NUMBER_OF_RUNS/=1 .OR. NUMBER_OF_THIS_RUN/=1) &
- call exit_mpi(myrank,'NUMBER_OF_RUNS and NUMBER_OF_THIS_RUN must be 1 for NOISE TOMOGRAPHY! check DATA/Par_file')
- if (ROTATE_SEISMOGRAMS_RT) &
- call exit_mpi(myrank,'Do NOT rotate seismograms in the code, change ROTATE_SEISMOGRAMS_RT in DATA/Par_file')
- if (SAVE_ALL_SEISMOS_IN_ONE_FILE .OR. USE_BINARY_FOR_LARGE_FILE) &
- call exit_mpi(myrank,'Please set SAVE_ALL_SEISMOS_IN_ONE_FILE and USE_BINARY_FOR_LARGE_FILE to be .false.')
- if (MOVIE_COARSE) &
- call exit_mpi(myrank,'Please set MOVIE_COARSE in DATA/Par_file to be .false.')
-
-
- if (NOISE_TOMOGRAPHY==1) then
- if (SIMULATION_TYPE/=1) &
- call exit_mpi(myrank,'NOISE_TOMOGRAPHY=1 requires SIMULATION_TYPE=1! check DATA/Par_file')
- else if (NOISE_TOMOGRAPHY==2) then
- if (SIMULATION_TYPE/=1) &
- call exit_mpi(myrank,'NOISE_TOMOGRAPHY=2 requires SIMULATION_TYPE=1! check DATA/Par_file')
- if (.not. SAVE_FORWARD) &
- call exit_mpi(myrank,'NOISE_TOMOGRAPHY=2 requires SAVE_FORWARD=.true.! check DATA/Par_file')
- else if (NOISE_TOMOGRAPHY==3) then
- if (SIMULATION_TYPE/=3) &
- call exit_mpi(myrank,'NOISE_TOMOGRAPHY=3 requires SIMULATION_TYPE=3! check DATA/Par_file')
- if (SAVE_FORWARD) &
- call exit_mpi(myrank,'NOISE_TOMOGRAPHY=3 requires SAVE_FORWARD=.false.! check DATA/Par_file')
- endif
- end subroutine check_parameters_noise
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
-! subroutine for NOISE TOMOGRAPHY
-! read and construct the "source" (source time function based upon noise spectrum) for "ensemble forward source"
- subroutine compute_arrays_source_noise(myrank, &
- xi_noise,eta_noise,gamma_noise,nu_single,noise_sourcearray, &
- xigll,yigll,zigll,NSTEP)
- implicit none
- include 'constants.h'
- include "OUTPUT_FILES/values_from_mesher.h"
- ! input parameters
- integer :: myrank, NSTEP
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLY) :: yigll
- double precision, dimension(NGLLZ) :: zigll
- double precision, dimension(NDIM,NDIM) :: nu_single ! rotation matrix at the master receiver
- ! output parameters
- real(kind=CUSTOM_REAL) :: noise_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NSTEP)
- ! local parameters
- integer itime, i, j, k, ios
- real(kind=CUSTOM_REAL) :: junk
- real(kind=CUSTOM_REAL) :: noise_src(NSTEP),noise_src_u(NDIM,NSTEP)
- double precision, dimension(NDIM) :: nu_master ! component direction chosen at the master receiver
- double precision :: xi_noise, eta_noise, gamma_noise ! master receiver location
- double precision,parameter :: scale_displ_inv = 1.d0/R_EARTH ! non-dimesional scaling
- double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
- hgammar(NGLLZ), hpgammar(NGLLZ)
- character(len=150) :: filename
-
-
- noise_src(:) = 0._CUSTOM_REAL
- ! noise file (source time function)
- filename = 'NOISE_TOMOGRAPHY/'//'S_squared'
- open(unit=IIN_NOISE,file=trim(filename),status='old',action='read',iostat=ios)
- if( ios /= 0) &
- call exit_MPI(myrank, 'file '//trim(filename)//' does NOT exist! This file is generated by Matlab scripts')
-
- do itime =1,NSTEP
- read(IIN_NOISE,*,iostat=ios) junk, noise_src(itime)
- if( ios /= 0) call exit_MPI(myrank,&
- 'file '//trim(filename)//' has wrong length, please check your simulation duration')
- enddo
- close(IIN_NOISE)
-
- ! master receiver component direction, \nu_master
- filename = 'NOISE_TOMOGRAPHY/'//'nu_master'
- open(unit=IIN_NOISE,file=trim(filename),status='old',action='read',iostat=ios)
- if( ios /= 0) call exit_MPI(myrank,&
- 'file '//trim(filename)//' does NOT exist! nu_master is the component direction (NEZ) for master receiver')
-
- do itime =1,3
- read(IIN_NOISE,*,iostat=ios) nu_master(itime)
- if( ios /= 0) call exit_MPI(myrank,&
- 'file '//trim(filename)//' has wrong length, the vector should have three components (NEZ)')
- enddo
- close(IIN_NOISE)
-
- if (myrank == 0) then
- open(unit=IOUT_NOISE,file='OUTPUT_FILES/nu_master',status='unknown',action='write')
- WRITE(IOUT_NOISE,*) 'The direction (NEZ) of selected component of master receiver is', nu_master
- close(IOUT_NOISE)
- endif
-
- ! rotates to cartesian
- do itime = 1, NSTEP
- noise_src_u(:,itime) = nu_single(1,:) * noise_src(itime) * nu_master(1) &
- + nu_single(2,:) * noise_src(itime) * nu_master(2) &
- + nu_single(3,:) * noise_src(itime) * nu_master(3)
- enddo
-
- ! receiver interpolators
- call lagrange_any(xi_noise,NGLLX,xigll,hxir,hpxir)
- call lagrange_any(eta_noise,NGLLY,yigll,hetar,hpetar)
- call lagrange_any(gamma_noise,NGLLZ,zigll,hgammar,hpgammar)
-
- ! adds interpolated source contribution to all GLL points within this element
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- do itime = 1, NSTEP
- noise_sourcearray(:,i,j,k,itime) = hxir(i) * hetar(j) * hgammar(k) * noise_src_u(:,itime)
- enddo
- enddo
- enddo
- enddo
-
- end subroutine compute_arrays_source_noise
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
-! subroutine for NOISE TOMOGRAPHY
-! step 1: calculate the "ensemble forward source"
-! add noise spectrum to the location of master receiver
- subroutine add_source_master_rec_noise(myrank,nrec, &
- NSTEP,accel_crust_mantle,noise_sourcearray, &
- ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
- it,irec_master_noise)
- implicit none
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
- ! input parameters
- integer :: myrank,nrec,NSTEP, irec_master_noise
- integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSTEP) :: noise_sourcearray
- real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle ! both input and output
- ! output parameters
- ! local parameters
- integer :: i,j,k,iglob,it
-
-
- ! adds noise source (only if this proc carries the noise)
- if(myrank == islice_selected_rec(irec_master_noise)) then
- ! adds nosie source contributions
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec_master_noise))
- accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
- + noise_sourcearray(:,i,j,k,it)
- enddo
- enddo
- enddo
- endif
-
- end subroutine add_source_master_rec_noise
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
-! subroutine for NOISE TOMOGRAPHY
-! step 1: calculate the "ensemble forward source"
-! save surface movie (displacement) at every time steps, for step 2 & 3.
- subroutine noise_save_surface_movie(myrank,nmovie_points,displ_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz, &
- ibelm_top_crust_mantle,ibool_crust_mantle,nspec_top, &
- NIT,it,LOCAL_PATH)
- implicit none
- include 'mpif.h'
- include "precision.h"
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
- ! input parameters
- integer :: myrank,nmovie_points,nspec_top,NIT,it
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
- character(len=150) :: LOCAL_PATH
- ! output parameters
- ! local parameters
- integer :: ipoin,ispec2D,ispec,i,j,k,iglob
- real(kind=CUSTOM_REAL), dimension(nmovie_points) :: &
- store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz
- character(len=150) :: outputname
-
-
- ! get coordinates of surface mesh and surface displacement
- ipoin = 0
- do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
- ispec = ibelm_top_crust_mantle(ispec2D)
-
- k = NGLLZ
-
- ! loop on all the points inside the element
- do j = 1,NGLLY,NIT
- do i = 1,NGLLX,NIT
- ipoin = ipoin + 1
- iglob = ibool_crust_mantle(i,j,k,ispec)
- store_val_x(ipoin) = xstore_crust_mantle(iglob)
- store_val_y(ipoin) = ystore_crust_mantle(iglob)
- store_val_z(ipoin) = zstore_crust_mantle(iglob)
- store_val_ux(ipoin) = displ_crust_mantle(1,iglob)
- store_val_uy(ipoin) = displ_crust_mantle(2,iglob)
- store_val_uz(ipoin) = displ_crust_mantle(3,iglob)
- enddo
- enddo
-
- enddo
-
- ! save surface motion to disk
- ! LOCAL storage is better than GLOBAL, because we have to save the 'movie' at every time step
- ! also note that the surface movie does NOT have to be shared with other nodes/CPUs
- ! change LOCAL_PATH specified in "DATA/Par_file"
- write(outputname,"('/proc',i6.6,'_surface_movie',i6.6)") myrank, it
- open(unit=IOUT_NOISE,file=trim(LOCAL_PATH)//outputname,status='unknown',form='unformatted',action='write')
- write(IOUT_NOISE) store_val_ux
- write(IOUT_NOISE) store_val_uy
- write(IOUT_NOISE) store_val_uz
- close(IOUT_NOISE)
-
- end subroutine noise_save_surface_movie
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
-! subroutine for NOISE TOMOGRAPHY
-! step 2/3: calculate/reconstructe the "ensemble forward wavefield"
-! read surface movie (displacement) at every time steps, injected as the source of "ensemble forward wavefield"
-! in step 2, call noise_read_add_surface_movie(..., NSTEP-it+1 ,...)
-! in step 3, call noise_read_add_surface_movie(..., it ,...)
- subroutine noise_read_add_surface_movie(myrank,nmovie_points,accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- store_val_ux,store_val_uy,store_val_uz, &
- ibelm_top_crust_mantle,ibool_crust_mantle,nspec_top, &
- NIT,it,LOCAL_PATH,jacobian2D_top_crust_mantle,wgllwgll_xy)
- implicit none
- include 'mpif.h'
- include "precision.h"
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
- ! input parameters
- integer :: myrank,nmovie_points,nspec_top,NIT,it
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: jacobian2D_top_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle ! both input and output
- real(kind=CUSTOM_REAL), dimension(nmovie_points) :: normal_x_noise,normal_y_noise,normal_z_noise, mask_noise
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- character(len=150) :: LOCAL_PATH
- ! output parameters
- ! local parameters
- integer :: ipoin,ispec2D,ispec,i,j,k,iglob,ios
- real(kind=CUSTOM_REAL), dimension(nmovie_points) :: store_val_ux,store_val_uy,store_val_uz
- real(kind=CUSTOM_REAL) :: eta
- character(len=150) :: outputname
-
-
- ! read surface movie
- write(outputname,"('/proc',i6.6,'_surface_movie',i6.6)") myrank, it
- open(unit=IIN_NOISE,file=trim(LOCAL_PATH)//outputname,status='old',form='unformatted',action='read',iostat=ios)
- if( ios /= 0) call exit_MPI(myrank,'file '//trim(outputname)//' does NOT exist!')
- read(IIN_NOISE) store_val_ux
- read(IIN_NOISE) store_val_uy
- read(IIN_NOISE) store_val_uz
- close(IIN_NOISE)
-
- ! get coordinates of surface mesh and surface displacement
- ipoin = 0
- do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
- ispec = ibelm_top_crust_mantle(ispec2D)
-
- k = NGLLZ
-
- ! loop on all the points inside the element
- do j = 1,NGLLY,NIT
- do i = 1,NGLLX,NIT
- ipoin = ipoin + 1
- iglob = ibool_crust_mantle(i,j,k,ispec)
-
- eta = store_val_ux(ipoin) * normal_x_noise(ipoin) + &
- store_val_uy(ipoin) * normal_y_noise(ipoin) + &
- store_val_uz(ipoin) * normal_z_noise(ipoin)
-
- accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + eta * mask_noise(ipoin) * normal_x_noise(ipoin) &
- * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
- accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + eta * mask_noise(ipoin) * normal_y_noise(ipoin) &
- * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
- accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + eta * mask_noise(ipoin) * normal_z_noise(ipoin) &
- * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
- enddo
- enddo
-
- enddo
-
- end subroutine noise_read_add_surface_movie
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
-! subroutine for NOISE TOMOGRAPHY
-! step 3: constructing noise source strength kernel
- subroutine compute_kernels_strength_noise(myrank,ibool_crust_mantle, &
- Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
- nmovie_points,normal_x_noise,normal_y_noise,normal_z_noise, &
- nspec_top,ibelm_top_crust_mantle,LOCAL_PATH)
- implicit none
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
- ! input parameters
- integer :: myrank,nmovie_points,it,nspec_top
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- real(kind=CUSTOM_REAL) :: deltat
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(nmovie_points) :: normal_x_noise,normal_y_noise,normal_z_noise
- character(len=150) :: LOCAL_PATH
- ! output parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- Sigma_kl_crust_mantle
- ! local parameters
- integer :: i,j,k,ispec,iglob,ipoin,ispec2D,ios
- real(kind=CUSTOM_REAL) :: eta
- real(kind=CUSTOM_REAL), dimension(nmovie_points) :: store_val_ux,store_val_uy,store_val_uz
- character(len=150) :: outputname
-
-
- ! read surface movie, needed for Sigma_kl_crust_mantle
- write(outputname,"('/proc',i6.6,'_surface_movie',i6.6)") myrank, it
- open(unit=IIN_NOISE,file=trim(LOCAL_PATH)//outputname,status='old',form='unformatted',action='read',iostat=ios)
- if( ios /= 0) call exit_MPI(myrank,'file '//trim(outputname)//' does NOT exist!')
-
- read(IIN_NOISE) store_val_ux
- read(IIN_NOISE) store_val_uy
- read(IIN_NOISE) store_val_uz
- close(IIN_NOISE)
-
- ! noise source strength kernel
- ! to keep similar structure to other kernels, the source strength kernel is saved as a volumetric kernel
- ! but only updated at the surface, because the noise is generated there
- ipoin = 0
- do ispec2D = 1, nspec_top
- ispec = ibelm_top_crust_mantle(ispec2D)
-
- k = NGLLZ
-
- ! loop on all the points inside the element
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool_crust_mantle(i,j,k,ispec)
-
- eta = store_val_ux(ipoin) * normal_x_noise(ipoin) + &
- store_val_uy(ipoin) * normal_y_noise(ipoin) + &
- store_val_uz(ipoin) * normal_z_noise(ipoin)
-
- Sigma_kl_crust_mantle(i,j,k,ispec) = Sigma_kl_crust_mantle(i,j,k,ispec) &
- + deltat * eta * ( normal_x_noise(ipoin) * displ_crust_mantle(1,iglob) &
- + normal_y_noise(ipoin) * displ_crust_mantle(2,iglob) &
- + normal_z_noise(ipoin) * displ_crust_mantle(3,iglob) )
- enddo
- enddo
-
- enddo
-
- end subroutine compute_kernels_strength_noise
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
-! subroutine for NOISE TOMOGRAPHY
-! step 3: save noise source strength kernel
- subroutine save_kernels_strength_noise(myrank,LOCAL_PATH,Sigma_kl_crust_mantle)
- implicit none
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
- ! input parameters
- integer myrank
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: Sigma_kl_crust_mantle
- character(len=150) :: LOCAL_PATH
- ! output parameters
- ! local parameters
- character(len=150) :: prname
-
-
- call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
-
- open(unit=IOUT_NOISE,file=trim(prname)//'Sigma_kernel.bin',status='unknown',form='unformatted',action='write')
- write(IOUT_NOISE) Sigma_kl_crust_mantle ! need to put dimensions back (not done yet)
- close(IOUT_NOISE)
- end subroutine save_kernels_strength_noise
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/param_reader.c
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/param_reader.c 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/param_reader.c 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,211 +0,0 @@
-/*
- !=====================================================================
- !
- ! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
- ! --------------------------------------------------
- !
- ! Main authors: Dimitri Komatitsch and Jeroen Tromp
- ! Princeton University, USA
- ! and University of Pau / CNRS / INRIA, France
- ! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
- ! December 2010
- !
- ! 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.
- !
- !=====================================================================
- */
-
-/*
-
-by Dennis McRitchie (Princeton University, USA)
-
- January 7, 2010 - par_file parsing
- ..
- You'll notice that the heart of the parser is a complex regular
- expression that is compiled within the C code, and then used to split
- the lines appropriately. It does all the heavy lifting. I don't know of
- any way to do this in Fortran. I believe that to accomplish this in
- Fortran, you'd have to write a lot of procedural string manipulation
- code, for which Fortran is not very well suited.
-
- But Fortran-C mixes are pretty common these days, so I would not expect
- any problems on that account. There are no wrapper functions used: just
- the C routine called directly from a Fortran routine. Also, regarding
- the use of C, I assumed this would not be a problem since there are
- already six C files that make up part of the build (though they all are
- related to the pyre-framework).
- ..
-*/
-
-#define _GNU_SOURCE
-#include "config.h"
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <regex.h>
-
-#define LINE_MAX 255
-
-/*
- * Mac OS X's gcc does not support strnlen and strndup.
- * So we define them here conditionally, to avoid duplicate definitions
- * on other systems.
- */
-#ifdef __APPLE__
-size_t strnlen (const char *string, size_t maxlen)
-{
- const char *end = memchr (string, '\0', maxlen);
- return end ? (size_t) (end - string) : maxlen;
-}
-
-char *strndup (char const *s, size_t n)
-{
- size_t len = strnlen (s, n);
- char *new = malloc (len + 1);
-
- if (new == NULL)
- return NULL;
-
- new[len] = '\0';
- return memcpy (new, s, len);
-}
-#endif
-/*===============================================================*/
-
-FILE * fid;
-
-void
-FC_FUNC_(param_open,PARAM_OPEN)(char * filename, int * length, int * ierr)
-{
- char * fncopy;
- char * blank;
-
- // Trim the file name.
- fncopy = strndup(filename, *length);
- blank = strchr(fncopy, ' ');
- if (blank != NULL) {
- fncopy[blank - fncopy] = '\0';
- }
- if ((fid = fopen(fncopy, "r")) == NULL) {
- printf("Can't open '%s'\n", fncopy);
- *ierr = 1;
- return;
- }
- free(fncopy);
-}
-
-void
-FC_FUNC_(param_close,PARAM_CLOSE)()
-{
- fclose(fid);
-}
-
-void
-FC_FUNC_(param_read,PARAM_READ)(char * string_read, int * string_read_len, char * name, int * name_len, int * ierr)
-{
- char * namecopy;
- char * blank;
- char * namecopy2;
- int status;
- regex_t compiled_pattern;
- char line[LINE_MAX];
- int regret;
- regmatch_t parameter[3];
- char * keyword;
- char * value;
-
- // Trim the keyword name we're looking for.
- namecopy = strndup(name, *name_len);
- blank = strchr(namecopy, ' ');
- if (blank != NULL) {
- namecopy[blank - namecopy] = '\0';
- }
- // Then get rid of any dot-terminated prefix.
- namecopy2 = strchr(namecopy, '.');
- if (namecopy2 != NULL) {
- namecopy2 += 1;
- } else {
- namecopy2 = namecopy;
- }
- /* Regular expression for parsing lines from param file.
- ** Good luck reading this regular expression. Basically, the lines of
- ** the parameter file should be of the form 'parameter = value'. Blank
- ** lines, lines containing only white space and lines whose first non-
- ** whitespace character is '#' are ignored. White space is generally
- ** ignored. As you will see later in the code, if both parameter and
- ** value are not specified the line is ignored.
- */
- char pattern[] = "^[ \t]*([^# \t]*)[ \t]*=[ \t]*([^# \t]*)[ \t]*(#.*){0,1}$";
-
- // Compile the regular expression.
- status = regcomp(&compiled_pattern, pattern, REG_EXTENDED);
- if (status != 0) {
- printf("regcomp returned error %d\n", status);
- }
- // Position the open file to the beginning.
- if (fseek(fid, 0, SEEK_SET) != 0) {
- printf("Can't seek to begining of parameter file\n");
- *ierr = 1;
- regfree(&compiled_pattern);
- return;
- }
- // Read every line in the file.
- while (fgets(line, LINE_MAX, fid) != NULL) {
- // Get rid of the ending newline.
- int linelen = strlen(line);
- if (line[linelen-1] == '\n') {
- line[linelen-1] = '\0';
- }
- /* Test if line matches the regular expression pattern, if so
- ** return position of keyword and value */
- regret = regexec(&compiled_pattern, line, 3, parameter, 0);
- // If no match, check the next line.
- if (regret == REG_NOMATCH) {
- continue;
- }
- // If any error, bail out with an error message.
- if(regret != 0) {
- printf("regexec returned error %d\n", regret);
- *ierr = 1;
- regfree(&compiled_pattern);
- return;
- }
- // printf("Line read = %s\n", line);
- // If we have a match, extract the keyword from the line.
- keyword = strndup(line+parameter[1].rm_so, parameter[1].rm_eo-parameter[1].rm_so);
- // If the keyword is not the one we're looking for, check the next line.
- if (strcmp(keyword, namecopy2) != 0) {
- free(keyword);
- continue;
- }
- free(keyword);
- regfree(&compiled_pattern);
- // If it matches, extract the value from the line.
- value = strndup(line+parameter[2].rm_so, parameter[2].rm_eo-parameter[2].rm_so);
- // Clear out the return string with blanks, copy the value into it, and return.
- memset(string_read, ' ', *string_read_len);
- strncpy(string_read, value, strlen(value));
- free(value);
- free(namecopy);
- *ierr = 0;
- return;
- }
- // If no keyword matches, print out error and die.
- printf("No match in parameter file for keyword %s\n", namecopy);
- free(namecopy);
- regfree(&compiled_pattern);
- *ierr = 1;
- return;
-}
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/precision.h.in
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/precision.h.in 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/precision.h.in 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 0
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! March 2010
-!
-! 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.
-!
-!=====================================================================
-
-! @configure_input@
-
-!
-! 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 = @CUSTOM_MPI_TYPE@
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/prepare_timerun.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/prepare_timerun.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/prepare_timerun.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,711 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine prepare_timerun_rmass(myrank,rmass_ocean_load,rmass_crust_mantle, &
- rmass_outer_core,rmass_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_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, &
- 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_scalar,buffer_received_faces_scalar, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,npoin2D_max_all_CM_IC)
-
- implicit none
-
- include 'mpif.h'
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank,npoin2D_max_all_CM_IC
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
- 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
-
- integer ichunk,iproc_xi,iproc_eta
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-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_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
-
- integer, 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
-
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle, &
- iboolfaces_outer_core,iboolfaces_inner_core
-
- integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
- integer npoin2D_faces_outer_core(NUMFACES_SHARED)
- integer npoin2D_faces_inner_core(NUMFACES_SHARED)
-
- ! 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
-
- ! 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
-
- ! buffers for send and receive between faces of the slices and the chunks
- real(kind=CUSTOM_REAL), dimension(NGLOB2DMAX_XY_VAL) :: &
- 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_CM) :: &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar
-
- integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS
-
- integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
- integer NGLOB2DMAX_XY
-
- ! local parameters
- integer :: ier
-
- ! 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_VAL) then
- call assemble_MPI_scalar_block(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_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY,NCHUNKS_VAL)
- endif
-
- ! crust and mantle
- call assemble_MPI_scalar_block(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_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY,NCHUNKS_VAL)
-
- ! outer core
- call assemble_MPI_scalar_block(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_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY,NCHUNKS_VAL)
-
- ! inner core
- call assemble_MPI_scalar_block(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_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE),NGLOB2DMAX_XY,NCHUNKS_VAL)
-
- if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix'
-
- end subroutine prepare_timerun_rmass
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_timerun_centralcube(myrank,rmass_inner_core, &
- iproc_xi,iproc_eta,ichunk, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM, &
- 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
-
- include 'mpif.h'
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
-
- integer ichunk,iproc_xi,iproc_eta
-
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: &
- xstore_inner_core,ystore_inner_core,zstore_inner_core
-
- integer nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
- nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
-
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
- integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
-
- integer nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube, &
- npoin2D_cube_from_slices,receiver_cube_from_slices
-
- integer, dimension(non_zero_nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
- integer, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices) :: ibool_central_cube
- double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices,buffer_slices2
- double precision, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM) :: &
- buffer_all_cube_from_slices
-
- ! local parameters
- integer :: ndim_assemble
-
- ! create buffers to assemble with the central cube
- call create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NCHUNKS_VAL,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_block(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.
-
- end subroutine prepare_timerun_centralcube
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_timerun_constants(myrank,NSTEP, &
- DT,t0,scale_t,scale_t_inv,scale_displ,scale_veloc, &
- deltat,deltatover2,deltatsqover2, &
- b_deltat,b_deltatover2,b_deltatsqover2, &
- two_omega_earth,A_array_rotation,B_array_rotation, &
- b_two_omega_earth, SIMULATION_TYPE)
-
-! precomputes constants for time integration
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank,NSTEP
-
- double precision DT
- double precision t0
-
-
- double precision scale_t,scale_t_inv,scale_displ,scale_veloc
-
- real(kind=CUSTOM_REAL) deltat,deltatover2,deltatsqover2
- real(kind=CUSTOM_REAL) b_deltat,b_deltatover2,b_deltatsqover2
-
- real(kind=CUSTOM_REAL) two_omega_earth
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
- A_array_rotation,B_array_rotation
-
- real(kind=CUSTOM_REAL) b_two_omega_earth
-
- integer SIMULATION_TYPE
-
- ! local parameters
-
-
- 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_t_inv = dsqrt(PI*GRAV*RHOAV)
-
- scale_displ = R_EARTH
-
- scale_veloc = scale_displ * scale_t_inv
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- deltat = sngl(DT*scale_t_inv)
- else
- deltat = DT*scale_t_inv
- endif
- deltatover2 = 0.5d0*deltat
- deltatsqover2 = 0.5d0*deltat*deltat
-
- if (SIMULATION_TYPE == 3) then
- if(CUSTOM_REAL == SIZE_REAL) then
- b_deltat = - sngl(DT*scale_t_inv)
- else
- b_deltat = - DT*scale_t_inv
- endif
- b_deltatover2 = 0.5d0*b_deltat
- b_deltatsqover2 = 0.5d0*b_deltat*b_deltat
- endif
-
- ! non-dimensionalized rotation rate of the Earth times two
- if(ROTATION_VAL) then
- ! distinguish between single and double precision for reals
- if (SIMULATION_TYPE == 1) then
- if(CUSTOM_REAL == SIZE_REAL) then
- two_omega_earth = sngl(2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv))
- else
- two_omega_earth = 2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv)
- endif
- else
- if(CUSTOM_REAL == SIZE_REAL) then
- two_omega_earth = - sngl(2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv))
- else
- two_omega_earth = - 2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv)
- endif
- endif
-
- A_array_rotation = 0._CUSTOM_REAL
- B_array_rotation = 0._CUSTOM_REAL
-
- if (SIMULATION_TYPE == 3) then
- if(CUSTOM_REAL == SIZE_REAL) then
- b_two_omega_earth = sngl(2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv))
- else
- b_two_omega_earth = 2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv)
- endif
- endif
- else
- two_omega_earth = 0._CUSTOM_REAL
- if (SIMULATION_TYPE == 3) b_two_omega_earth = 0._CUSTOM_REAL
- endif
-
-
- end subroutine prepare_timerun_constants
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_timerun_gravity(myrank, &
- minus_g_cmb,minus_g_icb, &
- minus_gravity_table,minus_deriv_gravity_table, &
- density_table,d_ln_density_dr_table,minus_rho_g_over_kappa_fluid, &
- ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
-
-! precomputes gravity factors
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- real(kind=CUSTOM_REAL) minus_g_cmb,minus_g_icb
-
- ! lookup table every km for gravity
- double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table, &
- minus_deriv_gravity_table,density_table, &
- d_ln_density_dr_table,minus_rho_g_over_kappa_fluid
-
- logical ONE_CRUST
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME, &
- R80,R220,R400,R600,R670,R771,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- ! local parameters
- double precision :: rspl_gravity(NR),gspl(NR),gspl2(NR)
- double precision :: radius,radius_km,g,dg
- double precision :: g_cmb_dble,g_icb_dble
- double precision :: rho,drhodr,vp,vs,Qkappa,Qmu
- integer :: int_radius,idoubling,nspl_gravity
-
- ! 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
- if(GRAVITY_VAL) then
- call make_gravity(nspl_gravity,rspl_gravity,gspl,gspl2,ONE_CRUST)
- do int_radius = 1,NRAD_GRAVITY
- radius = dble(int_radius) / (R_EARTH_KM * 10.d0)
- call spline_evaluation(rspl_gravity,gspl,gspl2,nspl_gravity,radius,g)
-
- ! use PREM density profile to calculate gravity (fine for other 1D models)
- idoubling = 0
- call model_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)
-
- dg = 4.0d0*rho - 2.0d0*g/radius
-
- minus_gravity_table(int_radius) = - g
- minus_deriv_gravity_table(int_radius) = - dg
- density_table(int_radius) = rho
- minus_rho_g_over_kappa_fluid(int_radius) = - g / vp**2
- enddo
-
- ! make sure fluid array is only assigned in outer core between 1222 and 3478 km
- ! lookup table is defined every 100 m
- do int_radius = 1,NRAD_GRAVITY
- radius_km = dble(int_radius) / 10.d0
- if(radius_km > RCMB/1000.d0 - 3.d0) &
- minus_rho_g_over_kappa_fluid(int_radius) = minus_rho_g_over_kappa_fluid(nint((RCMB/1000.d0 - 3.d0)*10.d0))
- if(radius_km < RICB/1000.d0 + 3.d0) &
- minus_rho_g_over_kappa_fluid(int_radius) = minus_rho_g_over_kappa_fluid(nint((RICB/1000.d0 + 3.d0)*10.d0))
- enddo
-
- ! compute gravity value at CMB and ICB once and for all
- radius = RCMB / R_EARTH
- call spline_evaluation(rspl_gravity,gspl,gspl2,nspl_gravity,radius,g_cmb_dble)
-
- radius = RICB / R_EARTH
- call spline_evaluation(rspl_gravity,gspl,gspl2,nspl_gravity,radius,g_icb_dble)
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- minus_g_cmb = sngl(- g_cmb_dble)
- minus_g_icb = sngl(- g_icb_dble)
- else
- minus_g_cmb = - g_cmb_dble
- minus_g_icb = - g_icb_dble
- endif
-
- else
-
- ! 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 model_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
-
- endif
-
- end subroutine prepare_timerun_gravity
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_timerun_attenuation(myrank, &
- factor_scale_crust_mantle,one_minus_sum_beta_crust_mantle,factor_common_crust_mantle, &
- factor_scale_inner_core,one_minus_sum_beta_inner_core,factor_common_inner_core, &
- 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, &
- muvstore_crust_mantle,muhstore_crust_mantle,idoubling_crust_mantle, &
- muvstore_inner_core, &
- SIMULATION_TYPE,MOVIE_VOLUME,muvstore_crust_mantle_3dmovie, &
- c11store_inner_core,c12store_inner_core,c13store_inner_core, &
- c33store_inner_core,c44store_inner_core, &
- alphaval,betaval,gammaval,b_alphaval,b_betaval,b_gammaval, &
- deltat,b_deltat,LOCAL_PATH)
-
- ! precomputes attenuation factors
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- ! memory variables and standard linear solids for attenuation
- real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT4) :: one_minus_sum_beta_crust_mantle, factor_scale_crust_mantle
- real(kind=CUSTOM_REAL), dimension(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
-
- 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
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
- muvstore_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
- muhstore_crust_mantle
- integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
- muvstore_inner_core
-
-
- integer SIMULATION_TYPE
- logical MOVIE_VOLUME
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: muvstore_crust_mantle_3dmovie
-
- 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
-
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval, betaval, gammaval
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: b_alphaval, b_betaval, b_gammaval
-
- real(kind=CUSTOM_REAL) deltat,b_deltat
-
- character(len=150) LOCAL_PATH
-
- ! local parameters
- 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
- 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, dimension(N_SLS) :: alphaval_dble, betaval_dble, gammaval_dble
- double precision, dimension(N_SLS) :: tau_sigma_dble
-
- double precision :: scale_factor,scale_factor_minus_one
- real(kind=CUSTOM_REAL) :: mul
- integer :: ispec,i,j,k
- character(len=150) :: prname
-
- ! get and store PREM attenuation model
-
- ! CRUST_MANTLE ATTENUATION
- call create_name_database(prname, myrank, IREGION_CRUST_MANTLE, LOCAL_PATH)
- call get_attenuation_model_3D(myrank, prname, omsb_crust_mantle_dble, &
- factor_common_crust_mantle_dble,factor_scale_crust_mantle_dble,tau_sigma_dble,NSPEC_CRUST_MANTLE)
-
- ! INNER_CORE ATTENUATION
- call create_name_database(prname, myrank, IREGION_INNER_CORE, LOCAL_PATH)
- call get_attenuation_model_3D(myrank, prname, omsb_inner_core_dble, &
- factor_common_inner_core_dble,factor_scale_inner_core_dble,tau_sigma_dble,NSPEC_INNER_CORE)
-
- 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
- scale_factor = factor_scale_crust_mantle(i,j,k,ispec)
-
- 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
- if(MOVIE_VOLUME .and. SIMULATION_TYPE==3) then
- ! store the original value of \mu to comput \mu*\eps
- muvstore_crust_mantle_3dmovie(i,j,k,ispec)=muvstore_crust_mantle(i,j,k,ispec)
- endif
- muvstore_crust_mantle(i,j,k,ispec) = muvstore_crust_mantle(i,j,k,ispec) * scale_factor
- 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
- scale_factor_minus_one = factor_scale_inner_core(i,j,k,ispec) - 1.0
-
- 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
-
- muvstore_inner_core(i,j,k,ispec) = muvstore_inner_core(i,j,k,ispec) * factor_scale_inner_core(i,j,k,ispec)
-
- enddo
- enddo
- enddo
- enddo ! END DO INNER CORE
-
- ! precompute Runge-Kutta coefficients
- call get_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
-
- if (SIMULATION_TYPE == 3) then
- call get_attenuation_memory_values(tau_sigma_dble, b_deltat, alphaval_dble, betaval_dble, gammaval_dble)
- if(CUSTOM_REAL == SIZE_REAL) then
- b_alphaval = sngl(alphaval_dble)
- b_betaval = sngl(betaval_dble)
- b_gammaval = sngl(gammaval_dble)
- else
- b_alphaval = alphaval_dble
- b_betaval = betaval_dble
- b_gammaval = gammaval_dble
- endif
- endif
-
- end subroutine prepare_timerun_attenuation
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/read_arrays_buffers_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_arrays_buffers_solver.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_arrays_buffers_solver.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,289 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine read_arrays_buffers_solver(iregion_code,myrank, &
- iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
- npoin2D_xi,npoin2D_eta, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces,npoin2D_faces,iboolcorner, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL, &
- NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA,LOCAL_PATH,NCHUNKS)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
-
- integer iregion_code,myrank,NCHUNKS,ier
-
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
- integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL
- integer NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA
-
- integer npoin2D_faces(NUMFACES_SHARED)
-
- character(len=150) LOCAL_PATH
-
- integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
- integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
- integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
- integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
-
- integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
-
-! allocate array for messages for corners
- integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
- integer npoin2D_xi_mesher,npoin2D_eta_mesher
- integer npoin1D_corner
-
- integer imsg,icount_faces,icount_corners
- integer ipoin1D,ipoin2D
-
- double precision xdummy,ydummy,zdummy
-
-! processor identification
- character(len=150) OUTPUT_FILES,prname,filename
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! create the name for the database of the current slide and region
- call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
-
-! read 2-D addressing for summation between slices along xi with MPI
-
-! read iboolleft_xi of this slice
- open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_xi.txt',status='old',action='read')
- npoin2D_xi(1) = 1
- 350 continue
- read(IIN,*) iboolleft_xi(npoin2D_xi(1)),xdummy,ydummy,zdummy
- if(iboolleft_xi(npoin2D_xi(1)) > 0) then
- npoin2D_xi(1) = npoin2D_xi(1) + 1
- goto 350
- endif
-! subtract the line that contains the flag after the last point
- npoin2D_xi(1) = npoin2D_xi(1) - 1
-! read nb of points given by the mesher
- read(IIN,*) npoin2D_xi_mesher
- if(npoin2D_xi(1) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(1) /= npoin2D_xi_mesher) &
- call exit_MPI(myrank,'incorrect iboolleft_xi read')
- close(IIN)
-
-! read iboolright_xi of this slice
- open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_xi.txt',status='old',action='read')
- npoin2D_xi(2) = 1
- 360 continue
- read(IIN,*) iboolright_xi(npoin2D_xi(2)),xdummy,ydummy,zdummy
- if(iboolright_xi(npoin2D_xi(2)) > 0) then
- npoin2D_xi(2) = npoin2D_xi(2) + 1
- goto 360
- endif
-! subtract the line that contains the flag after the last point
- npoin2D_xi(2) = npoin2D_xi(2) - 1
-! read nb of points given by the mesher
- read(IIN,*) npoin2D_xi_mesher
- if(npoin2D_xi(2) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(2) /= npoin2D_xi_mesher) &
- call exit_MPI(myrank,'incorrect iboolright_xi read')
- close(IIN)
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '# max of points in MPI buffers along xi npoin2D_xi = ', &
- maxval(npoin2D_xi(:))
- write(IMAIN,*) '# max of array elements transferred npoin2D_xi*NDIM = ', &
- maxval(npoin2D_xi(:))*NDIM
- write(IMAIN,*)
- endif
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! read 2-D addressing for summation between slices along eta with MPI
-
-! read iboolleft_eta of this slice
- open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_eta.txt',status='old',action='read')
- npoin2D_eta(1) = 1
- 370 continue
- read(IIN,*) iboolleft_eta(npoin2D_eta(1)),xdummy,ydummy,zdummy
- if(iboolleft_eta(npoin2D_eta(1)) > 0) then
- npoin2D_eta(1) = npoin2D_eta(1) + 1
- goto 370
- endif
-! subtract the line that contains the flag after the last point
- npoin2D_eta(1) = npoin2D_eta(1) - 1
-! read nb of points given by the mesher
- read(IIN,*) npoin2D_eta_mesher
- if(npoin2D_eta(1) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(1) /= npoin2D_eta_mesher) &
- call exit_MPI(myrank,'incorrect iboolleft_eta read')
- close(IIN)
-
-! read iboolright_eta of this slice
- open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='old',action='read')
- npoin2D_eta(2) = 1
- 380 continue
- read(IIN,*) iboolright_eta(npoin2D_eta(2)),xdummy,ydummy,zdummy
- if(iboolright_eta(npoin2D_eta(2)) > 0) then
- npoin2D_eta(2) = npoin2D_eta(2) + 1
- goto 380
- endif
-! subtract the line that contains the flag after the last point
- npoin2D_eta(2) = npoin2D_eta(2) - 1
-! read nb of points given by the mesher
- read(IIN,*) npoin2D_eta_mesher
- if(npoin2D_eta(2) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(2) /= npoin2D_eta_mesher) &
- call exit_MPI(myrank,'incorrect iboolright_eta read')
- close(IIN)
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '#max of points in MPI buffers along eta npoin2D_eta = ', &
- maxval(npoin2D_eta(:))
- write(IMAIN,*) '#max of array elements transferred npoin2D_eta*NDIM = ', &
- maxval(npoin2D_eta(:))*NDIM
- write(IMAIN,*)
- endif
-
-
-!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! read chunk messages only if more than one chunk
- if(NCHUNKS /= 1) then
-
-! read messages to assemble between chunks with MPI
-
- if(myrank == 0) then
-
-! 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
- 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
- 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
- call MPI_BCAST(imsg_type,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iprocfrom_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iprocto_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(iproc_master_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iproc_worker1_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iproc_worker2_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
-!---- read indirect addressing for each message for faces of the chunks
-!---- 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)) 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')
-
-! read file with 2D buffer for faces
- if(myrank == iprocfrom_faces(imsg)) then
- write(filename,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
- else if(myrank == iprocto_faces(imsg)) then
- write(filename,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
- endif
-
- open(unit=IIN,file=prname(1:len_trim(prname))//filename,status='old',action='read')
- read(IIN,*) npoin2D_faces(icount_faces)
- if(npoin2D_faces(icount_faces) > NGLOB2DMAX_XY) &
- call exit_MPI(myrank,'incorrect nb of points in face buffer')
- do ipoin2D = 1,npoin2D_faces(icount_faces)
- read(IIN,*) iboolfaces(ipoin2D,icount_faces),xdummy,ydummy,zdummy
- enddo
- close(IIN)
- endif
- enddo
-
-
-!---- read indirect addressing for each message for corners of the chunks
-!---- a given slice can belong to at most one corner
- icount_corners = 0
- do imsg = 1,NCORNERSCHUNKS
- if(myrank == iproc_master_corners(imsg) .or. &
- myrank == iproc_worker1_corners(imsg) .or. &
- myrank == iproc_worker2_corners(imsg)) 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')
-
-! read file with 1D buffer for corner
- if(myrank == iproc_master_corners(imsg)) then
- write(filename,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
- else if(myrank == iproc_worker1_corners(imsg)) then
- write(filename,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
- else if(myrank == iproc_worker2_corners(imsg)) then
- write(filename,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
- endif
-
-! matching codes
- open(unit=IIN,file=prname(1:len_trim(prname))//filename,status='old',action='read')
- read(IIN,*) npoin1D_corner
- if(npoin1D_corner /= NGLOB1D_RADIAL) &
- call exit_MPI(myrank,'incorrect nb of points in corner buffer')
- do ipoin1D = 1,npoin1D_corner
- read(IIN,*) iboolcorner(ipoin1D,icount_corners),xdummy,ydummy,zdummy
- enddo
- close(IIN)
- endif
- enddo
-
- endif
-
- end subroutine read_arrays_buffers_solver
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/read_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_arrays_solver.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_arrays_solver.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,197 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! read arrays created by the mesher
-
- subroutine read_arrays_solver(iregion_code,myrank, &
- rho_vp,rho_vs,xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- rhostore, kappavstore,muvstore,kappahstore,muhstore,eta_anisostore, &
- nspec_iso,nspec_tiso,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,is_on_a_slice_edge,rmass,rmass_ocean_load,nspec,nglob, &
- READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY, &
- ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS,LOCAL_PATH,ABSORBING_CONDITIONS)
-
- implicit none
-
- include "constants.h"
-
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer iregion_code,myrank
-
-! flags to know if we should read Vs and anisotropy arrays
- logical READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS,ABSORBING_CONDITIONS
-
- character(len=150) LOCAL_PATH
-
- integer nspec,nglob
-
- integer nspec_iso,nspec_tiso,nspec_ani
-
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-
-! material properties
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec_iso)
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec_iso)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec_iso)
-
-! additional arrays for anisotropy stored only where needed to save memory
- real(kind=CUSTOM_REAL) kappahstore(NGLLX,NGLLY,NGLLZ,nspec_tiso)
- real(kind=CUSTOM_REAL) muhstore(NGLLX,NGLLY,NGLLZ,nspec_tiso)
- real(kind=CUSTOM_REAL) eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec_tiso)
-
-! additional arrays for full anisotropy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store,c34store, &
- c35store,c36store,c44store,c45store,c46store,c55store,c56store,c66store
-
-! Stacey
- real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec)
-
-! mass matrix and additional ocean load mass matrix
- real(kind=CUSTOM_REAL), dimension(nglob) :: rmass,rmass_ocean_load
-
-! global addressing
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer, dimension(nspec) :: idoubling
-
-! this for non blocking MPI
- logical, dimension(nspec) :: is_on_a_slice_edge
-
-! processor identification
- character(len=150) prname
-
-! create the name for the database of the current slide and region
- call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
-
- open(unit=IIN,file=prname(1:len_trim(prname))//'solver_data_1.bin', &
- status='old',action='read',form='unformatted')
-
- read(IIN) xix
- read(IIN) xiy
- read(IIN) xiz
- read(IIN) etax
- read(IIN) etay
- read(IIN) etaz
- read(IIN) gammax
- read(IIN) gammay
- read(IIN) gammaz
-
-! model arrays
- read(IIN) rhostore
- read(IIN) kappavstore
-
- if(READ_KAPPA_MU) read(IIN) muvstore
-
-! for anisotropy, gravity and rotation
-
- if(TRANSVERSE_ISOTROPY .and. READ_TISO) then
- read(IIN) kappahstore
- read(IIN) muhstore
- read(IIN) eta_anisostore
- endif
-
- if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
- read(IIN) c11store
- read(IIN) c12store
- read(IIN) c13store
- read(IIN) c33store
- read(IIN) c44store
- endif
-
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
- read(IIN) c11store
- read(IIN) c12store
- read(IIN) c13store
- read(IIN) c14store
- read(IIN) c15store
- read(IIN) c16store
- read(IIN) c22store
- read(IIN) c23store
- read(IIN) c24store
- read(IIN) c25store
- read(IIN) c26store
- read(IIN) c33store
- read(IIN) c34store
- read(IIN) c35store
- read(IIN) c36store
- read(IIN) c44store
- read(IIN) c45store
- read(IIN) c46store
- read(IIN) c55store
- read(IIN) c56store
- read(IIN) c66store
- endif
-
-! Stacey
- if(ABSORBING_CONDITIONS) then
-
- if(iregion_code == IREGION_CRUST_MANTLE) then
- read(IIN) rho_vp
- read(IIN) rho_vs
- else if(iregion_code == IREGION_OUTER_CORE) then
- read(IIN) rho_vp
- endif
-
- endif
-
-! mass matrix
- read(IIN) rmass
-
-! read additional ocean load mass matrix
- if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) read(IIN) rmass_ocean_load
-
- close(IIN)
-
-! read coordinates of the mesh
-
- open(unit=IIN,file=prname(1:len_trim(prname))//'solver_data_2.bin', &
- status='old',action='read',form='unformatted')
- read(IIN) xstore
- read(IIN) ystore
- read(IIN) zstore
-
- read(IIN) ibool
-
- read(IIN) idoubling
-
- read(IIN) is_on_a_slice_edge
-
- close(IIN)
-
- end subroutine read_arrays_solver
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/read_compute_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_compute_parameters.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_compute_parameters.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,2374 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,&
- MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX, &
- NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top, &
- this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube, &
- HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,&
- USE_BINARY_FOR_LARGE_FILE,EMULATE_ONLY,NOISE_TOMOGRAPHY)
-
-
- implicit none
-
- include "constants.h"
-
-
-! parameters read from parameter file
- integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read,NOISE_TOMOGRAPHY
-
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
- HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM, &
- MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,&
- MOVIE_SOUTH_DEG,RECORD_LENGTH_IN_MINUTES
-
- logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
- MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- ABSORBING_CONDITIONS,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
-
- character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
-
-! parameters to be computed based upon parameters above read from file
- integer NSTEP,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,REFERENCE_1D_MODEL,THREE_D_MODEL
-
- double precision DT,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, &
- RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
-
- double precision MOVIE_TOP,MOVIE_BOTTOM,MOVIE_EAST,MOVIE_WEST,&
- MOVIE_NORTH,MOVIE_SOUTH
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ONE_CRUST,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- ATTENUATION_3D,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE, &
- EMULATE_ONLY
-
- integer NEX_MAX
-
- double precision ELEMENT_WIDTH
-
- 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
-
-! for the cut doublingbrick improvement
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer :: last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge
- 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
-
-
- ! reads in Par_file values
- call read_parameter_file(OUTPUT_FILES,LOCAL_PATH,MODEL, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, &
- NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
- HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM,RECORD_LENGTH_IN_MINUTES, &
- MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,MOVIE_SOUTH_DEG,&
- ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
- MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION,ABSORBING_CONDITIONS,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,NOISE_TOMOGRAPHY)
-
- ! converts values to radians
- 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
- ! converts movie top/bottom depths to radii
- MOVIE_TOP = (R_EARTH_KM-MOVIE_TOP_KM)/R_EARTH_KM
- MOVIE_BOTTOM = (R_EARTH_KM-MOVIE_BOTTOM_KM)/R_EARTH_KM
-
- ! 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
-
- 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
-
- ! turns on/off corresponding 1-D/3-D model flags
- ! and sets radius for each discontinuity and ocean density values
- call get_model_parameters(MODEL,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
- CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO, &
- ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY, &
- OCEANS,TOPOGRAPHY, &
- ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R120,R220,R400,R600,R670,R771, &
- RTOPDDOUBLEPRIME,RCMB,RICB,RMOHO_FICTITIOUS_IN_MESHER, &
- R80_FICTITIOUS_IN_MESHER,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS)
-
-
- ! sets time step size and number of layers
- ! right distribution is determined based upon maximum value of NEX
- NEX_MAX = max(NEX_XI,NEX_ETA)
- call rcp_set_timestep_and_layers(DT,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD, &
- NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,&
- NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,R_CENTRAL_CUBE, &
- NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
- ANISOTROPIC_INNER_CORE)
-
- ! 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)
-
-!<YANGL
- if ( NOISE_TOMOGRAPHY /= 0 ) NSTEP = 2*NSTEP-1 ! time steps needs to be doubled, due to +/- branches
-!>YANGL
-
- ! 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
- endif
-
- ! 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)
-
-
- ! checks parameters
- call rcp_check_parameters(NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
- NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
- ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM)
-
- ! 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.
- 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
-
- 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
- call rcp_define_all_layers(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,&
- RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
- ONE_CRUST,ner,ratio_sampling_array,&
- NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer, &
- r_bottom,r_top,this_region_has_a_doubling,&
- ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,&
- elem_doubling_bottom_outer_core,&
- DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
- DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval,&
- doubling_index,rmins,rmaxs)
-
-
- ! calculates number of elements (NSPEC)
- call rcp_count_elements(NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NPROC,&
- NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- ner,ratio_sampling_array,this_region_has_a_doubling, &
- ifirst_region,ilast_region,iter_region,iter_layer,&
- doubling,tmp_sum,tmp_sum_xi,tmp_sum_eta, &
- NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
- nb_lay_sb, nspec_sb, nglob_surf, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, INCLUDE_CENTRAL_CUBE, &
- last_doubling_layer, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,&
- nglob_edge_v,to_remove)
-
-
- ! calculates number of points (NGLOB)
- call rcp_count_points(NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB,&
- nblocks_xi,nblocks_eta,ner,ratio_sampling_array,&
- this_region_has_a_doubling,&
- ifirst_region, ilast_region, iter_region, iter_layer, &
- doubling, padding, tmp_sum, &
- INCLUDE_CENTRAL_CUBE,NER_TOP_CENTRAL_CUBE_ICB,NEX_XI, &
- NUMBER_OF_MESH_LAYERS,layer_offset, &
- nb_lay_sb, nglob_vol, nglob_surf, nglob_edge, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
-
-
-
- end subroutine read_compute_parameters
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine rcp_set_timestep_and_layers(DT,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD, &
- NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,&
- NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,R_CENTRAL_CUBE, &
- NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
- ANISOTROPIC_INNER_CORE)
-
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
-
- integer NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB
-
- integer NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL
-
- double precision DT
- double precision R_CENTRAL_CUBE
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
-
- logical ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL,ANISOTROPIC_INNER_CORE
-
-! local variables
- integer multiplication_factor
-
- !----
- !---- 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
- ! time step
- DT = 0.252d0
-
- ! attenuation period range
- MIN_ATTENUATION_PERIOD = 30
- MAX_ATTENUATION_PERIOD = 1500
-
- ! number of element layers in each mesh region
- 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
-
- ! radius of central cube
- 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
-
- !> Hejun
- ! avoids elongated elements below the 670-discontinuity,
- ! since for model REFERENCE_MODEL_1DREF,
- ! the 670-discontinuity is moved up to 650 km depth.
- if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1DREF) then
- NER_771_670 = NER_771_670 + 1
- end if
-
- !----
- !---- 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
- ! 1D models honor 1D spherical moho
- if (.not. ONE_CRUST) then
- ! case 1D + two crustal layers
- if (NER_CRUST < 2 ) NER_CRUST = 2
- ! makes time step smaller
- if(NEX_MAX*multiplication_factor <= 160) then
- DT = 0.20d0
- else if(NEX_MAX*multiplication_factor <= 256) then
- DT = 0.20d0
- endif
- endif
- else
- ! 3D models: must have two element layers for crust
- if (NER_CRUST < 2 ) NER_CRUST = 2
- ! makes time step smaller
- if(NEX_MAX*multiplication_factor <= 80) then
- DT = 0.125d0
- else 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( .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, CRUSTAL, &
- HONOR_1D_SPHERICAL_MOHO, REFERENCE_1D_MODEL)
-
- 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
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
-
- ! time step reductions are based on empirical values (..somehow)
-
- ! following models need special attention, at least for global simulations:
- if( NCHUNKS == 6 ) then
-
- ! makes time step smaller for this ref model, otherwise becomes unstable in fluid
- if (REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) &
- DT = DT*(1.d0 - 0.3d0)
-
- ! using inner core anisotropy, simulations might become unstable in solid
- if( ANISOTROPIC_INNER_CORE ) then
- ! DT = DT*(1.d0 - 0.1d0) not working yet...
- stop 'anisotropic inner core - unstable feature, uncomment this line in read_compute_parameters.f90'
- endif
-
- endif
-
- ! following models need special attention, regardless of number of chunks:
- ! it makes the time step smaller for this ref model, otherwise becomes unstable in fluid
- if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) &
- DT = DT*(1.d0 - 0.8d0) ! *0.20d0
-
-
- if( ITYPE_CRUSTAL_MODEL == ICRUST_CRUSTMAPS ) &
- DT = DT*(1.d0 - 0.3d0)
-
- ! decreases time step as otherwise the solution might become unstable for rougher/unsmoothed models
- ! if( THREE_D_MODEL == THREE_D_MODEL_PPM ) &
- ! DT = DT * (1.d0 - 0.2d0)
-
- ! takes a 5% safety margin on the maximum stable time step
- ! which was obtained by trial and error
- DT = DT * (1.d0 - 0.05d0)
-
- ! adapts number of element layers in crust and time step for regional simulations
- if( REGIONAL_MOHO_MESH ) then
- ! hard coded number of crustal element layers and time step
-
- ! checks
- if( NCHUNKS > 1 ) stop 'regional moho mesh: NCHUNKS error in rcp_set_timestep_and_layers'
- if( HONOR_1D_SPHERICAL_MOHO ) return
-
- ! original values
- !print*,'NER:',NER_CRUST
- !print*,'DT:',DT
-
- ! enforce 3 element layers
- NER_CRUST = 3
-
- ! increased stability, empirical
- DT = DT*(1.d0 + 0.5d0)
-
- if( REGIONAL_MOHO_MESH_EUROPE ) DT = 0.14 ! europe
- if( REGIONAL_MOHO_MESH_ASIA ) DT = 0.15 ! asia & middle east
-
- endif
-
-
- end subroutine rcp_set_timestep_and_layers
-
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine rcp_check_parameters(NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
- NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
- ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM)
-
- implicit none
-
- include "constants.h"
-
- integer NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA,NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
-
- logical ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS,&
- INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM
-
-
-! checks parameters
-
- if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
- stop 'NCHUNKS must be either 1, 2, 3 or 6'
-
- ! 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'
-
- if(ABSORBING_CONDITIONS .and. NCHUNKS == 6) &
- stop 'cannot have absorbing conditions in the full Earth'
-
- if(ABSORBING_CONDITIONS .and. NCHUNKS == 3) &
- stop 'absorbing conditions not supported for three chunks yet'
-
- if(ATTENUATION_3D .and. .not. ATTENUATION) &
- stop 'need ATTENUATION to use ATTENUATION_3D'
-
- if (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'
-
- ! 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 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'
-
- ! support for only one slice per chunk has been discontinued when there is more than one chunk
- ! because it induces topological problems, and we are not interested in using small meshes
- if(NCHUNKS > 1 .and. (NPROC_XI == 1 .or. NPROC_ETA == 1)) stop 'support for only one slice per chunk has been discontinued'
-
- end subroutine rcp_check_parameters
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine rcp_define_all_layers(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,&
- RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
- ONE_CRUST,ner,ratio_sampling_array,&
- NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer, &
- r_bottom,r_top,this_region_has_a_doubling,&
- ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,&
- elem_doubling_bottom_outer_core,&
- DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
- DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval,&
- doubling_index,rmins,rmaxs)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! definition of general mesh parameters below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
- integer NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB
- integer NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer
-
- double precision RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
-
- logical ONE_CRUST
-
- 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
-
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-
-
-! 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
-
- ! default case:
- ! no fourth doubling at the bottom of the outer core
-
- if (SUPPRESS_CRUSTAL_MESH) then
-
- ! suppress the crustal layers
- ! will be replaced by an extension of the mantle: R_EARTH is not modified,
- ! but no more crustal doubling
-
- 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.
- last_doubling_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_FICTITIOUS_IN_MESHER
-
- 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_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- 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_FICTITIOUS_IN_MESHER / 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_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / 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
-
- ! 1D models:
- ! 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.
-
- 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.
- last_doubling_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_FICTITIOUS_IN_MESHER
-
- r_top(3) = R80_FICTITIOUS_IN_MESHER
- 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_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = R80_FICTITIOUS_IN_MESHER / 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
-
- ! default case for 3D models:
- ! contains the crustal layers
- ! doubling at the base of the crust
-
- 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) ! regional mesh: ner(1) = 1 since NER_CRUST=3
- ner( 2) = ceiling (NER_CRUST / 2.d0) ! ner(2) = 2
- 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.
- last_doubling_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_FICTITIOUS_IN_MESHER
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- 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_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / 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
-
- ! 4th doubling case:
- ! includes fourth doubling at the bottom of the outer core
-
- if (SUPPRESS_CRUSTAL_MESH) then
-
- ! suppress the crustal layers
- ! will be replaced by an extension of the mantle: R_EARTH is not modified,
- ! but no more crustal doubling
-
- 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.
- last_doubling_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_FICTITIOUS_IN_MESHER
-
- 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_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- 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_FICTITIOUS_IN_MESHER / 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_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / 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
-
- ! 1D models:
- ! 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.
-
- 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.
- last_doubling_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_FICTITIOUS_IN_MESHER
-
- r_top(3) = R80_FICTITIOUS_IN_MESHER
- 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_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = R80_FICTITIOUS_IN_MESHER / 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
-
- ! for 3D models:
- ! contains the crustal layers
- ! doubling at the base of the crust
-
- 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.
- last_doubling_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_FICTITIOUS_IN_MESHER
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- 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_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / 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
-
-
- end subroutine rcp_define_all_layers
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine rcp_count_elements(NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NPROC,&
- NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- ner,ratio_sampling_array,this_region_has_a_doubling, &
- ifirst_region,ilast_region,iter_region,iter_layer, &
- doubling,tmp_sum,tmp_sum_xi,tmp_sum_eta, &
- NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
- nb_lay_sb, nspec_sb, nglob_surf, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, INCLUDE_CENTRAL_CUBE, &
- last_doubling_layer, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,&
- nglob_edge_v,to_remove)
-
-
- implicit none
-
- include "constants.h"
-
-
-! parameters to be computed based upon parameters above read from file
- integer NPROC,NEX_XI,NEX_ETA,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,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
-
-
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
-
-
- integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, tmp_sum, tmp_sum_xi, tmp_sum_eta
- integer :: NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
- nb_lay_sb, nspec_sb, nglob_surf
-
-
-! for the cut doublingbrick improvement
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- logical :: INCLUDE_CENTRAL_CUBE
- integer :: last_doubling_layer
- 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
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! calculation of number of elements (NSPEC) below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ratio_divide_central_cube = maxval(ratio_sampling_array(1:NUMBER_OF_MESH_LAYERS))
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 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 == last_doubling_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
- divider = 1
- doubling = 0
- nb_lay_sb = 0
- nspec2D_xi_sb = 0
- nspec2D_eta_sb = 0
- 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 ! iter_layer
-
- 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 ! iter_region
-
- ! 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, try to recompile :) '
-
-
- end subroutine rcp_count_elements
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine rcp_count_points(NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB,&
- nblocks_xi,nblocks_eta,ner,ratio_sampling_array,&
- this_region_has_a_doubling,&
- ifirst_region, ilast_region, iter_region, iter_layer, &
- doubling, padding, tmp_sum, &
- INCLUDE_CENTRAL_CUBE,NER_TOP_CENTRAL_CUBE_ICB,NEX_XI, &
- NUMBER_OF_MESH_LAYERS,layer_offset, &
- nb_lay_sb, nglob_vol, nglob_surf, nglob_edge, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! calculation of number of points (NGLOB) below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
-
-! parameters to be computed based upon parameters above read from file
- integer NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, dimension(MAX_NUM_REGIONS) :: &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB
-
- integer NER_TOP_CENTRAL_CUBE_ICB,NEX_XI
- integer nblocks_xi,nblocks_eta
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
-
- integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, padding, tmp_sum
- integer :: NUMBER_OF_MESH_LAYERS,layer_offset, &
- nb_lay_sb, nglob_vol, nglob_surf, nglob_edge
-
-! for the cut doublingbrick improvement
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,INCLUDE_CENTRAL_CUBE
- integer :: last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 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 == last_doubling_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 rcp_count_points
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/read_forward_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_forward_arrays.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_forward_arrays.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,249 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine read_forward_arrays_startrun(myrank,NSTEP, &
- SIMULATION_TYPE,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
- it_begin,it_end, &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
- displ_inner_core,veloc_inner_core,accel_inner_core, &
- displ_outer_core,veloc_outer_core,accel_outer_core, &
- R_memory_crust_mantle,R_memory_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
- A_array_rotation,B_array_rotation, &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
- b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
- b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
-
-! reads in saved wavefields
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank,NSTEP
-
- integer SIMULATION_TYPE
-
- integer NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,it_begin,it_end
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
- displ_inner_core,veloc_inner_core,accel_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
- displ_outer_core,veloc_outer_core,accel_outer_core
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: &
- R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
- R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: &
- epsilondev_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
- A_array_rotation,B_array_rotation
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: &
- b_R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- b_epsilondev_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: &
- b_R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- b_epsilondev_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
- b_A_array_rotation,b_B_array_rotation
-
- character(len=150) LOCAL_PATH
-
- !local parameters
- character(len=150) outputname
-
- ! define correct time steps if restart files
- if(NUMBER_OF_RUNS < 1 .or. NUMBER_OF_RUNS > 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'
-
- if(NUMBER_OF_RUNS == 3) then
- if(NUMBER_OF_THIS_RUN == 1) then
- it_begin = 1
- it_end = NSTEP/3
- else if(NUMBER_OF_THIS_RUN == 2) then
- it_begin = NSTEP/3 + 1
- it_end = 2*(NSTEP/3)
- else
- it_begin = 2*(NSTEP/3) + 1
- it_end = NSTEP
- endif
-
- else if(NUMBER_OF_RUNS == 2) then
- if(NUMBER_OF_THIS_RUN == 1) then
- it_begin = 1
- it_end = NSTEP/2
- else
- it_begin = NSTEP/2 + 1
- it_end = NSTEP
- endif
-
- else
- it_begin = 1
- it_end = NSTEP
- endif
-
- ! read files back from local disk or MT tape system if restart file
- if(NUMBER_OF_THIS_RUN > 1) then
- write(outputname,"('dump_all_arrays',i6.6)") myrank
- open(unit=55,file=trim(LOCAL_PATH)//'/'//outputname,status='old',action='read',form='unformatted')
- read(55) displ_crust_mantle
- read(55) veloc_crust_mantle
- read(55) accel_crust_mantle
- read(55) displ_inner_core
- read(55) veloc_inner_core
- read(55) accel_inner_core
- read(55) displ_outer_core
- read(55) veloc_outer_core
- read(55) accel_outer_core
- read(55) epsilondev_crust_mantle
- read(55) epsilondev_inner_core
- read(55) A_array_rotation
- read(55) B_array_rotation
- read(55) R_memory_crust_mantle
- read(55) R_memory_inner_core
- close(55)
- endif
-
- if (SIMULATION_TYPE == 3) then
- ! initializes
- b_displ_crust_mantle = 0._CUSTOM_REAL
- b_veloc_crust_mantle = 0._CUSTOM_REAL
- b_accel_crust_mantle = 0._CUSTOM_REAL
- b_displ_inner_core = 0._CUSTOM_REAL
- b_veloc_inner_core = 0._CUSTOM_REAL
- b_accel_inner_core = 0._CUSTOM_REAL
- b_displ_outer_core = 0._CUSTOM_REAL
- b_veloc_outer_core = 0._CUSTOM_REAL
- b_accel_outer_core = 0._CUSTOM_REAL
- b_epsilondev_crust_mantle = 0._CUSTOM_REAL
- b_epsilondev_inner_core = 0._CUSTOM_REAL
- if (ROTATION_VAL) then
- b_A_array_rotation = 0._CUSTOM_REAL
- b_B_array_rotation = 0._CUSTOM_REAL
- endif
- if (ATTENUATION_VAL) then
- b_R_memory_crust_mantle = 0._CUSTOM_REAL
- b_R_memory_inner_core = 0._CUSTOM_REAL
- endif
- endif
-
- end subroutine read_forward_arrays_startrun
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_forward_arrays(myrank, &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
- b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
- b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
-
-! reads in saved wavefields
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- ! backward/reconstructed wavefields
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: &
- b_R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- b_epsilondev_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: &
- b_R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- b_epsilondev_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
- b_A_array_rotation,b_B_array_rotation
-
- character(len=150) LOCAL_PATH
-
- !local parameters
- character(len=150) outputname
-
- write(outputname,'(a,i6.6,a)') 'proc',myrank,'_save_forward_arrays.bin'
- open(unit=55,file=trim(LOCAL_PATH)//'/'//outputname,status='old',action='read',form='unformatted')
- read(55) b_displ_crust_mantle
- read(55) b_veloc_crust_mantle
- read(55) b_accel_crust_mantle
- read(55) b_displ_inner_core
- read(55) b_veloc_inner_core
- read(55) b_accel_inner_core
- read(55) b_displ_outer_core
- read(55) b_veloc_outer_core
- read(55) b_accel_outer_core
- read(55) b_epsilondev_crust_mantle
- read(55) b_epsilondev_inner_core
- if (ROTATION_VAL) then
- read(55) b_A_array_rotation
- read(55) b_B_array_rotation
- endif
- if (ATTENUATION_VAL) then
- read(55) b_R_memory_crust_mantle
- read(55) b_R_memory_inner_core
- endif
- close(55)
-
- end subroutine read_forward_arrays
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_mesh_databases.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_mesh_databases.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,1012 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine read_mesh_databases(myrank,rho_vp_crust_mantle,rho_vs_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, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- nspec_iso,nspec_tiso,nspec_ani, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle,is_on_a_slice_edge_crust_mantle,rmass_crust_mantle,rmass_ocean_load, &
- vp_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, &
- rhostore_outer_core,kappavstore_outer_core, &
- ibool_outer_core,idoubling_outer_core,is_on_a_slice_edge_outer_core,rmass_outer_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
- c11store_inner_core,c12store_inner_core,c13store_inner_core, &
- c33store_inner_core,c44store_inner_core, &
- ibool_inner_core,idoubling_inner_core,is_on_a_slice_edge_inner_core,rmass_inner_core, &
- ABSORBING_CONDITIONS,LOCAL_PATH)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- ! Stacey
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: &
- rho_vp_crust_mantle,rho_vs_crust_mantle
-
- ! mesh parameters
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle
- ! arrays for anisotropic elements stored only where needed to save space
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
-
- ! arrays for full anisotropy only when needed
- 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, &
- 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
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
- ! mass matrix
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
- ! additional mass matrix for ocean load
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
-
- ! stacy outer core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_STACEY) :: vp_outer_core
- ! mesh parameters
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
- xstore_outer_core,ystore_outer_core,zstore_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
- 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(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
- rhostore_outer_core,kappavstore_outer_core
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
- integer, dimension(NSPEC_OUTER_CORE) :: idoubling_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_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, &
- rhostore_inner_core, kappavstore_inner_core,muvstore_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: &
- xstore_inner_core,ystore_inner_core,zstore_inner_core
- 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
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
-
- logical ABSORBING_CONDITIONS
- character(len=150) LOCAL_PATH
-
- !local parameters
- logical READ_KAPPA_MU,READ_TISO
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,1) :: dummy_array
-
-! this for non blocking MPI
- logical, dimension(NSPEC_CRUST_MANTLE) :: is_on_a_slice_edge_crust_mantle
- logical, dimension(NSPEC_OUTER_CORE) :: is_on_a_slice_edge_outer_core
- logical, dimension(NSPEC_INNER_CORE) :: is_on_a_slice_edge_inner_core
-
- ! 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
- call read_arrays_solver(IREGION_CRUST_MANTLE,myrank, &
- rho_vp_crust_mantle,rho_vs_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, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- nspec_iso,nspec_tiso,nspec_ani, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle,is_on_a_slice_edge_crust_mantle,rmass_crust_mantle,rmass_ocean_load, &
- NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
- READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY_VAL,ANISOTROPIC_3D_MANTLE_VAL, &
- ANISOTROPIC_INNER_CORE_VAL,OCEANS_VAL,LOCAL_PATH,ABSORBING_CONDITIONS)
-
- ! 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
-
- call read_arrays_solver(IREGION_OUTER_CORE,myrank, &
- vp_outer_core,dummy_array, &
- 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, &
- rhostore_outer_core,kappavstore_outer_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- nspec_iso,nspec_tiso,nspec_ani, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- ibool_outer_core,idoubling_outer_core,is_on_a_slice_edge_outer_core,rmass_outer_core,rmass_ocean_load, &
- NSPEC_OUTER_CORE,NGLOB_OUTER_CORE, &
- READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY_VAL,ANISOTROPIC_3D_MANTLE_VAL, &
- ANISOTROPIC_INNER_CORE_VAL,OCEANS_VAL,LOCAL_PATH,ABSORBING_CONDITIONS)
-
- ! 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
-
- call read_arrays_solver(IREGION_INNER_CORE,myrank, &
- dummy_array,dummy_array, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
- dummy_array,dummy_array,dummy_array, &
- nspec_iso,nspec_tiso,nspec_ani, &
- c11store_inner_core,c12store_inner_core,c13store_inner_core, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,c33store_inner_core, &
- dummy_array,dummy_array,dummy_array, &
- c44store_inner_core,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- ibool_inner_core,idoubling_inner_core,is_on_a_slice_edge_inner_core,rmass_inner_core,rmass_ocean_load, &
- NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY_VAL,ANISOTROPIC_3D_MANTLE_VAL, &
- ANISOTROPIC_INNER_CORE_VAL,OCEANS_VAL,LOCAL_PATH,ABSORBING_CONDITIONS)
-
- ! 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')
-
- end subroutine read_mesh_databases
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine read_mesh_databases_addressing(myrank, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, &
- iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,npoin2D_faces_crust_mantle, &
- iboolcorner_crust_mantle, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core, &
- iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_xi_outer_core,npoin2D_eta_outer_core,&
- iboolfaces_outer_core,npoin2D_faces_outer_core, &
- iboolcorner_outer_core, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core, &
- iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,npoin2D_faces_inner_core, &
- iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- LOCAL_PATH,OUTPUT_FILES, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XY,NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
- ichunk,iproc_xi,iproc_eta)
-
- implicit none
-
- include 'mpif.h'
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- ! 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
-
- 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
-
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle, &
- iboolfaces_outer_core,iboolfaces_inner_core
-
- integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
- integer npoin2D_faces_outer_core(NUMFACES_SHARED)
- integer npoin2D_faces_inner_core(NUMFACES_SHARED)
-
- ! 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
-
- ! 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
-
- character(len=150) LOCAL_PATH,OUTPUT_FILES
-
- integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
- integer NGLOB2DMAX_XY
-
- integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS
-
- ! 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
- integer ichunk,iproc_xi,iproc_eta
-
- ! local parameters
- integer :: ier,iproc,iproc_read
- integer :: NUM_FACES,NPROC_ONE_DIRECTION
-
- ! open file with global slice number addressing
- if(myrank == 0) then
- open(unit=IIN,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening addressing.txt')
- do iproc = 0,NPROCTOT_VAL-1
- read(IIN,*) iproc_read,ichunk,iproc_xi,iproc_eta
- if(iproc_read /= iproc) call exit_MPI(myrank,'incorrect slice number read')
- addressing(ichunk,iproc_xi,iproc_eta) = iproc
- ichunk_slice(iproc) = ichunk
- iproc_xi_slice(iproc) = iproc_xi
- iproc_eta_slice(iproc) = iproc_eta
- enddo
- close(IIN)
- endif
-
- ! broadcast the information read on the master to the nodes
- call MPI_BCAST(addressing,NCHUNKS_VAL*NPROC_XI_VAL*NPROC_ETA_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ichunk_slice,NPROCTOT_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iproc_xi_slice,NPROCTOT_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iproc_eta_slice,NPROCTOT_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- ! output a topology map of slices - fix 20x by nproc
- if (myrank == 0 .and. NCHUNKS_VAL == 6) then
- write(IMAIN,*) 'Spatial distribution of the slices'
- do iproc_xi = NPROC_XI_VAL-1, 0, -1
- write(IMAIN,'(20x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_AB
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- do iproc_xi = NPROC_XI_VAL-1, 0, -1
- write(IMAIN,'(1x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_BC
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(3x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_AC
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(3x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_BC_ANTIPODE
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- do iproc_xi = NPROC_XI_VAL-1, 0, -1
- write(IMAIN,'(20x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_AB_ANTIPODE
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- do iproc_xi = NPROC_XI_VAL-1, 0, -1
- write(IMAIN,'(20x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_AC_ANTIPODE
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- endif
-
- ! 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)
-
- ! define maximum size for message buffers
- ! use number of elements found in the mantle since it is the largest region
- NGLOB2DMAX_XY = max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE))
-
- ! 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_VAL
- ! total number of messages corresponding to these common faces
- NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
-
-
- ! read 2-D addressing for summation between slices with MPI
-
- ! mantle and crust
- call read_arrays_buffers_solver(IREGION_CRUST_MANTLE,myrank,iboolleft_xi_crust_mantle, &
- iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_crust_mantle,npoin2D_faces_crust_mantle, &
- iboolcorner_crust_mantle, &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT_VAL,NPROC_XI_VAL,NPROC_ETA_VAL,LOCAL_PATH,NCHUNKS_VAL)
-
- ! outer core
- call read_arrays_buffers_solver(IREGION_OUTER_CORE,myrank, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_outer_core,npoin2D_faces_outer_core, &
- iboolcorner_outer_core, &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT_VAL,NPROC_XI_VAL,NPROC_ETA_VAL,LOCAL_PATH,NCHUNKS_VAL)
-
- ! inner core
- call read_arrays_buffers_solver(IREGION_INNER_CORE,myrank, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_inner_core,npoin2D_faces_inner_core, &
- iboolcorner_inner_core, &
- NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE), &
- NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE),NGLOB2DMAX_XY,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT_VAL,NPROC_XI_VAL,NPROC_ETA_VAL,LOCAL_PATH,NCHUNKS_VAL)
-
-
- end subroutine read_mesh_databases_addressing
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_mesh_databases_coupling(myrank, &
- 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, &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle,normal_ymin_crust_mantle, &
- normal_ymax_crust_mantle,normal_bottom_crust_mantle,normal_top_crust_mantle, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle,jacobian2D_ymin_crust_mantle, &
- jacobian2D_ymax_crust_mantle,jacobian2D_bottom_crust_mantle,jacobian2D_top_crust_mantle, &
- 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, &
- normal_xmin_outer_core,normal_xmax_outer_core,normal_ymin_outer_core, &
- normal_ymax_outer_core,normal_bottom_outer_core,normal_top_outer_core, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core,jacobian2D_ymin_outer_core, &
- jacobian2D_ymax_outer_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
- 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, &
- ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
- ibelm_670_top,ibelm_670_bot,normal_moho,normal_400,normal_670, &
- k_top,k_bot,moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl, &
- LOCAL_PATH,SIMULATION_TYPE)
-
-! to couple mantle with outer core
- implicit none
-
- include 'mpif.h'
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- ! for crust/oceans coupling
- integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
- integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: jacobian2D_bottom_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: jacobian2D_top_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_CM) :: &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2DMAX_YMIN_YMAX_CM) :: &
- normal_ymin_crust_mantle,normal_ymax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: normal_bottom_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
-
- ! arrays to couple with the fluid regions by pointwise matching
- integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
- integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
- integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: &
- jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core
- 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
-
- ! inner core
- integer nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
- nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
- integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
- integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
-
- ! boundary
- integer, dimension(NSPEC2D_MOHO) :: ibelm_moho_top,ibelm_moho_bot
- integer, dimension(NSPEC2D_400) :: ibelm_400_top,ibelm_400_bot
- integer, dimension(NSPEC2D_670) :: ibelm_670_top,ibelm_670_bot
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO) :: normal_moho
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_400) :: normal_400
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_670) :: normal_670
-
- integer k_top,k_bot
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO) :: moho_kl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_400) :: d400_kl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_670) :: d670_kl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_CMB) :: cmb_kl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_ICB) :: icb_kl
-
- character(len=150) LOCAL_PATH
- integer SIMULATION_TYPE
-
- ! local parameters
- integer njunk1,njunk2,njunk3
- character(len=150) prname
-
-
- ! crust and mantle
- ! create name of database
- call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
-
- ! Stacey put back
- open(unit=27,file=prname(1:len_trim(prname))//'boundary.bin', &
- status='old',form='unformatted',action='read')
- read(27) nspec2D_xmin_crust_mantle
- read(27) nspec2D_xmax_crust_mantle
- read(27) nspec2D_ymin_crust_mantle
- read(27) nspec2D_ymax_crust_mantle
- read(27) njunk1
- read(27) njunk2
-
-! boundary parameters
- read(27) ibelm_xmin_crust_mantle
- read(27) ibelm_xmax_crust_mantle
- read(27) ibelm_ymin_crust_mantle
- read(27) ibelm_ymax_crust_mantle
- read(27) ibelm_bottom_crust_mantle
- read(27) ibelm_top_crust_mantle
-
- read(27) normal_xmin_crust_mantle
- read(27) normal_xmax_crust_mantle
- read(27) normal_ymin_crust_mantle
- read(27) normal_ymax_crust_mantle
- read(27) normal_bottom_crust_mantle
- read(27) normal_top_crust_mantle
-
- read(27) jacobian2D_xmin_crust_mantle
- read(27) jacobian2D_xmax_crust_mantle
- read(27) jacobian2D_ymin_crust_mantle
- read(27) jacobian2D_ymax_crust_mantle
- read(27) jacobian2D_bottom_crust_mantle
- read(27) jacobian2D_top_crust_mantle
- close(27)
-
-
- ! read parameters to couple fluid and solid regions
- !
- ! outer core
-
- ! create name of database
- call create_name_database(prname,myrank,IREGION_OUTER_CORE,LOCAL_PATH)
-
- ! boundary parameters
-
- ! Stacey put back
- open(unit=27,file=prname(1:len_trim(prname))//'boundary.bin', &
- status='old',form='unformatted',action='read')
- read(27) nspec2D_xmin_outer_core
- read(27) nspec2D_xmax_outer_core
- read(27) nspec2D_ymin_outer_core
- read(27) nspec2D_ymax_outer_core
- read(27) njunk1
- read(27) njunk2
-
- read(27) ibelm_xmin_outer_core
- read(27) ibelm_xmax_outer_core
- read(27) ibelm_ymin_outer_core
- read(27) ibelm_ymax_outer_core
- read(27) ibelm_bottom_outer_core
- read(27) ibelm_top_outer_core
-
- read(27) normal_xmin_outer_core
- read(27) normal_xmax_outer_core
- read(27) normal_ymin_outer_core
- read(27) normal_ymax_outer_core
- read(27) normal_bottom_outer_core
- read(27) normal_top_outer_core
-
- read(27) jacobian2D_xmin_outer_core
- read(27) jacobian2D_xmax_outer_core
- read(27) jacobian2D_ymin_outer_core
- read(27) jacobian2D_ymax_outer_core
- read(27) jacobian2D_bottom_outer_core
- read(27) jacobian2D_top_outer_core
- close(27)
-
-
- !
- ! inner core
- !
-
- ! create name of database
- call create_name_database(prname,myrank,IREGION_INNER_CORE,LOCAL_PATH)
-
- ! read info for vertical edges for central cube matching in inner core
- open(unit=27,file=prname(1:len_trim(prname))//'boundary.bin', &
- status='old',form='unformatted',action='read')
- read(27) nspec2D_xmin_inner_core
- read(27) nspec2D_xmax_inner_core
- read(27) nspec2D_ymin_inner_core
- read(27) nspec2D_ymax_inner_core
- read(27) njunk1
- read(27) njunk2
-
- ! boundary parameters
- read(27) ibelm_xmin_inner_core
- read(27) ibelm_xmax_inner_core
- read(27) ibelm_ymin_inner_core
- read(27) ibelm_ymax_inner_core
- read(27) ibelm_bottom_inner_core
- read(27) ibelm_top_inner_core
- close(27)
-
-
- ! -- Boundary Mesh for crust and mantle ---
- if (SAVE_BOUNDARY_MESH .and. SIMULATION_TYPE == 3) then
-
- call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
-
- open(unit=27,file=prname(1:len_trim(prname))//'boundary_disc.bin', &
- status='old',form='unformatted',action='read')
- read(27) njunk1,njunk2,njunk3
- if (njunk1 /= NSPEC2D_MOHO .and. njunk2 /= NSPEC2D_400 .and. njunk3 /= NSPEC2D_670) &
- call exit_mpi(myrank, 'Error reading ibelm_disc.bin file')
- read(27) ibelm_moho_top
- read(27) ibelm_moho_bot
- read(27) ibelm_400_top
- read(27) ibelm_400_bot
- read(27) ibelm_670_top
- read(27) ibelm_670_bot
- read(27) normal_moho
- read(27) normal_400
- read(27) normal_670
- close(27)
-
- k_top = 1
- k_bot = NGLLZ
-
- ! initialization
- moho_kl = 0.; d400_kl = 0.; d670_kl = 0.; cmb_kl = 0.; icb_kl = 0.
- endif
-
- end subroutine read_mesh_databases_coupling
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine read_mesh_databases_stacey(myrank, &
- nimin_crust_mantle,nimax_crust_mantle,njmin_crust_mantle, &
- njmax_crust_mantle,nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nimin_outer_core,nimax_outer_core,njmin_outer_core, &
- njmax_outer_core,nkmin_xi_outer_core,nkmin_eta_outer_core, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- reclen_zmin,NSPEC2D_BOTTOM, &
- SIMULATION_TYPE,SAVE_FORWARD,LOCAL_PATH,NSTEP)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_CM) :: &
- nimin_crust_mantle,nimax_crust_mantle,nkmin_eta_crust_mantle
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_CM) :: &
- njmin_crust_mantle,njmax_crust_mantle,nkmin_xi_crust_mantle
- integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
- integer reclen_xmin_crust_mantle, reclen_xmax_crust_mantle, reclen_ymin_crust_mantle, &
- reclen_ymax_crust_mantle
-
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_OC) :: nimin_outer_core,nimax_outer_core,nkmin_eta_outer_core
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_OC) :: njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core
- integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
- integer reclen_xmin_outer_core, reclen_xmax_outer_core,reclen_ymin_outer_core, &
- reclen_ymax_outer_core
-
- integer reclen_zmin
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_BOTTOM
-
- integer SIMULATION_TYPE
- logical SAVE_FORWARD
- character(len=150) LOCAL_PATH
- integer NSTEP
-
- ! local parameters
- character(len=150) prname
-
-
- ! crust and mantle
- ! create name of database
- call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
-
- ! read arrays for Stacey conditions
- open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin', &
- status='old',form='unformatted',action='read')
- read(27) nimin_crust_mantle
- read(27) nimax_crust_mantle
- read(27) njmin_crust_mantle
- read(27) njmax_crust_mantle
- read(27) nkmin_xi_crust_mantle
- read(27) nkmin_eta_crust_mantle
- close(27)
-
- if (nspec2D_xmin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- reclen_xmin_crust_mantle = CUSTOM_REAL * (NDIM * NGLLY * NGLLZ * nspec2D_xmin_crust_mantle)
- if (SIMULATION_TYPE == 3) then
-! open(unit=51,file=trim(prname)//'absorb_xmin.bin', &
-! status='old',action='read',form='unformatted',access='direct', &
-! recl=reclen_xmin_crust_mantle+2*4)
-! else
-! open(unit=51,file=trim(prname)//'absorb_xmin.bin', &
-! status='unknown',form='unformatted',access='direct',&
-! recl=reclen_xmin_crust_mantle+2*4)
-
- call open_file_abs_r(0,trim(prname)//'absorb_xmin.bin',len_trim(trim(prname)//'absorb_xmin.bin'), &
- reclen_xmin_crust_mantle*NSTEP)
- else
- call open_file_abs_w(0,trim(prname)//'absorb_xmin.bin',len_trim(trim(prname)//'absorb_xmin.bin'), &
- reclen_xmin_crust_mantle*NSTEP)
- endif
- endif
-
- if (nspec2D_xmax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- reclen_xmax_crust_mantle = CUSTOM_REAL * (NDIM * NGLLY * NGLLZ * nspec2D_xmax_crust_mantle)
- if (SIMULATION_TYPE == 3) then
-! open(unit=52,file=trim(prname)//'absorb_xmax.bin', &
-! status='old',action='read',form='unformatted',access='direct', &
-! recl=reclen_xmax_crust_mantle+2*4)
-! else
-! open(unit=52,file=trim(prname)//'absorb_xmax.bin', &
-! status='unknown',form='unformatted',access='direct', &
-! recl=reclen_xmax_crust_mantle+2*4)
-
- call open_file_abs_r(1,trim(prname)//'absorb_xmax.bin',len_trim(trim(prname)//'absorb_xmax.bin'), &
- reclen_xmax_crust_mantle*NSTEP)
- else
- call open_file_abs_w(1,trim(prname)//'absorb_xmax.bin',len_trim(trim(prname)//'absorb_xmax.bin'), &
- reclen_xmax_crust_mantle*NSTEP)
- endif
- endif
-
- if (nspec2D_ymin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- reclen_ymin_crust_mantle = CUSTOM_REAL * (NDIM * NGLLX * NGLLZ * nspec2D_ymin_crust_mantle)
- if (SIMULATION_TYPE == 3) then
-! open(unit=53,file=trim(prname)//'absorb_ymin.bin', &
-! status='old',action='read',form='unformatted',access='direct',&
-! recl=reclen_ymin_crust_mantle+2*4)
-! else
-! open(unit=53,file=trim(prname)//'absorb_ymin.bin', &
-! status='unknown',form='unformatted',access='direct',&
-! recl=reclen_ymin_crust_mantle+2*4)
-
- call open_file_abs_r(2,trim(prname)//'absorb_ymin.bin',len_trim(trim(prname)//'absorb_ymin.bin'), &
- reclen_ymin_crust_mantle*NSTEP)
- else
- call open_file_abs_w(2,trim(prname)//'absorb_ymin.bin',len_trim(trim(prname)//'absorb_ymin.bin'), &
- reclen_ymin_crust_mantle*NSTEP)
- endif
- endif
-
- if (nspec2D_ymax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- reclen_ymax_crust_mantle = CUSTOM_REAL * (NDIM * NGLLX * NGLLZ * nspec2D_ymax_crust_mantle)
- if (SIMULATION_TYPE == 3) then
-! open(unit=54,file=trim(prname)//'absorb_ymax.bin', &
-! status='old',action='read',form='unformatted',access='direct',&
-! recl=reclen_ymax_crust_mantle+2*4)
-! else
-! open(unit=54,file=trim(prname)//'absorb_ymax.bin', &
-! status='unknown',form='unformatted',access='direct',&
-! recl=reclen_ymax_crust_mantle+2*4)
-
- call open_file_abs_r(3,trim(prname)//'absorb_ymax.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
- reclen_ymax_crust_mantle*NSTEP)
- else
- call open_file_abs_w(3,trim(prname)//'absorb_ymax.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
- reclen_ymax_crust_mantle*NSTEP)
- endif
- endif
-
-
- ! outer core
- ! create name of database
- call create_name_database(prname,myrank,IREGION_OUTER_CORE,LOCAL_PATH)
-
- ! read arrays for Stacey conditions
- open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin', &
- status='old',form='unformatted',action='read')
- read(27) nimin_outer_core
- read(27) nimax_outer_core
- read(27) njmin_outer_core
- read(27) njmax_outer_core
- read(27) nkmin_xi_outer_core
- read(27) nkmin_eta_outer_core
- close(27)
-
- if (nspec2D_xmin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- reclen_xmin_outer_core = CUSTOM_REAL * (NGLLY * NGLLZ * nspec2D_xmin_outer_core)
- if (SIMULATION_TYPE == 3) then
-! open(unit=61,file=trim(prname)//'absorb_xmin.bin', &
-! status='old',action='read',form='unformatted',access='direct', &
-! recl=reclen_xmin_outer_core+2*4)
-! else
-! open(unit=61,file=trim(prname)//'absorb_xmin.bin', &
-! status='unknown',form='unformatted',access='direct',&
-! recl=reclen_xmin_outer_core+2*4)
-
- call open_file_abs_r(4,trim(prname)//'absorb_xmin.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
- reclen_xmin_outer_core*NSTEP)
- else
- call open_file_abs_w(4,trim(prname)//'absorb_xmin.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
- reclen_xmin_outer_core*NSTEP)
- endif
- endif
-
- if (nspec2D_xmax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- reclen_xmax_outer_core = CUSTOM_REAL * (NGLLY * NGLLZ * nspec2D_xmax_outer_core)
- if (SIMULATION_TYPE == 3) then
-! open(unit=62,file=trim(prname)//'absorb_xmax.bin', &
-! status='old',action='read',form='unformatted',access='direct', &
-! recl=reclen_xmax_outer_core+2*4)
-! else
-! open(unit=62,file=trim(prname)//'absorb_xmax.bin', &
-! status='unknown',form='unformatted',access='direct', &
-! recl=reclen_xmax_outer_core+2*4)
-
- call open_file_abs_r(5,trim(prname)//'absorb_xmax.bin',len_trim(trim(prname)//'absorb_xmax.bin'), &
- reclen_xmax_outer_core*NSTEP)
- else
- call open_file_abs_w(5,trim(prname)//'absorb_xmax.bin',len_trim(trim(prname)//'absorb_xmax.bin'), &
- reclen_xmax_outer_core*NSTEP)
- endif
-
- endif
-
- if (nspec2D_ymin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- reclen_ymin_outer_core = CUSTOM_REAL * (NGLLX * NGLLZ * nspec2D_ymin_outer_core)
- if (SIMULATION_TYPE == 3) then
-! open(unit=63,file=trim(prname)//'absorb_ymin.bin', &
-! status='old',action='read',form='unformatted',access='direct',&
-! recl=reclen_ymin_outer_core+2*4)
-! else
-! open(unit=63,file=trim(prname)//'absorb_ymin.bin', &
-! status='unknown',form='unformatted',access='direct',&
-! recl=reclen_ymin_outer_core+2*4)
-
- call open_file_abs_r(6,trim(prname)//'absorb_ymin.bin',len_trim(trim(prname)//'absorb_ymin.bin'), &
- reclen_ymin_outer_core*NSTEP)
- else
- call open_file_abs_w(6,trim(prname)//'absorb_ymin.bin',len_trim(trim(prname)//'absorb_ymin.bin'), &
- reclen_ymin_outer_core*NSTEP)
-
- endif
- endif
-
- if (nspec2D_ymax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- reclen_ymax_outer_core = CUSTOM_REAL * (NGLLX * NGLLZ * nspec2D_ymax_outer_core)
- if (SIMULATION_TYPE == 3) then
-! open(unit=64,file=trim(prname)//'absorb_ymax.bin', &
-! status='old',action='read',form='unformatted',access='direct',&
-! recl=reclen_ymax_outer_core+2*4)
-! else
-! open(unit=64,file=trim(prname)//'absorb_ymax.bin', &
-! status='unknown',form='unformatted',access='direct',&
-! recl=reclen_ymax_outer_core+2*4)
-
- call open_file_abs_r(7,trim(prname)//'absorb_ymax.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
- reclen_ymax_outer_core*NSTEP)
- else
- call open_file_abs_w(7,trim(prname)//'absorb_ymax.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
- reclen_ymax_outer_core*NSTEP)
-
- endif
- endif
-
- if (NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 .and. &
- (SIMULATION_TYPE == 3 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD)))then
- reclen_zmin = CUSTOM_REAL * (NGLLX * NGLLY * NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
- if (SIMULATION_TYPE == 3) then
-! open(unit=65,file=trim(prname)//'absorb_zmin.bin', &
-! status='old',action='read',form='unformatted',access='direct',&
-! recl=reclen_zmin+2*4)
-! else
-! open(unit=65,file=trim(prname)//'absorb_zmin.bin', &
-! status='unknown',form='unformatted',access='direct',&
-! recl=reclen_zmin+2*4)
-
- call open_file_abs_r(8,trim(prname)//'absorb_zmin.bin',len_trim(trim(prname)//'absorb_zmin.bin'), &
- reclen_zmin*NSTEP)
- else
- call open_file_abs_w(8,trim(prname)//'absorb_zmin.bin',len_trim(trim(prname)//'absorb_zmin.bin'), &
- reclen_zmin*NSTEP)
- endif
- endif
-
- end subroutine read_mesh_databases_stacey
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/read_parameter_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_parameter_file.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_parameter_file.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,194 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine read_parameter_file(OUTPUT_FILES,LOCAL_PATH,MODEL, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, &
- NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
- HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM,RECORD_LENGTH_IN_MINUTES, &
- MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,MOVIE_SOUTH_DEG,&
- ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
- MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION,ABSORBING_CONDITIONS,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,NOISE_TOMOGRAPHY)
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
- integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read,NOISE_TOMOGRAPHY
-
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
- HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM, &
- MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,&
- MOVIE_SOUTH_DEG,RECORD_LENGTH_IN_MINUTES
-
- logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
- MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- ABSORBING_CONDITIONS,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
-
- character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
-
-! local variables
- integer, external :: err_occurred
-
- ! gets the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
- ! opens the parameter file: DATA/Par_file
- call open_parameter_file()
-
- ! reads in values
- call read_value_integer(SIMULATION_TYPE, 'solver.SIMULATION_TYPE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: SIMULATION_TYPE'
- call read_value_integer(NOISE_TOMOGRAPHY, 'solver.NOISE_TOMOGRAPHY')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NOISE_TOMOGRAPHY'
- call read_value_logical(SAVE_FORWARD, 'solver.SAVE_FORWARD')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: SAVE_FORWARD'
- call read_value_integer(NCHUNKS, 'mesher.NCHUNKS')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NCHUNKS'
- 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: ANGULAR_WIDTH_XI...'
- 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: ANGULAR_WIDTH_ETA...'
- 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: CENTER_LATITUDE...'
- 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: CENTER_LONGITUDE...'
- 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: GAMMA_ROTATION...'
- ! 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: NEX_XI'
- call read_value_integer(NEX_ETA_read, 'mesher.NEX_ETA')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NEX_ETA'
- call read_value_integer(NPROC_XI_read, 'mesher.NPROC_XI')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NPROC_XI'
- call read_value_integer(NPROC_ETA_read, 'mesher.NPROC_ETA')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NPROC_ETA'
- call read_value_logical(OCEANS, 'model.OCEANS')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: OCEANS'
- call read_value_logical(ELLIPTICITY, 'model.ELLIPTICITY')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: ELLIPTICITIY'
- call read_value_logical(TOPOGRAPHY, 'model.TOPOGRAPHY')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: TOPOGRAPHY'
- call read_value_logical(GRAVITY, 'model.GRAVITY')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: GRAVITY'
- call read_value_logical(ROTATION, 'model.ROTATION')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: ROTATION'
- call read_value_logical(ATTENUATION, 'model.ATTENUATION')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: ATTENUATION'
- call read_value_logical(ABSORBING_CONDITIONS, 'solver.ABSORBING_CONDITIONS')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: ABSORBING_CONDITIONS'
- ! define the velocity model
- call read_value_string(MODEL, 'model.MODEL')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MODEL'
- call read_value_double_precision(RECORD_LENGTH_IN_MINUTES, 'solver.RECORD_LENGTH_IN_MINUTES')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: RECORD_LENGTH..'
- call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_SURFACE'
- call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_VOLUME'
- call read_value_logical(MOVIE_COARSE,'solver.MOVIE_COARSE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_COARSE'
- call read_value_integer(NTSTEP_BETWEEN_FRAMES, 'solver.NTSTEP_BETWEEN_FRAMES')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NTSTEP_BETWEEN_FRAMES'
- call read_value_double_precision(HDUR_MOVIE, 'solver.HDUR_MOVIE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: HDUR_MOVIE'
- call read_value_integer(MOVIE_VOLUME_TYPE, 'solver.MOVIE_VOLUME_TYPE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_VOLUME_TYPE'
- 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: MOVIE_TOP_KM'
- 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: MOVIE_BOTTOM_KM'
- 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: MOVIE_WEST_DEG'
- 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: MOVIE_EAST_DEG'
- 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: MOVIE_NORTH_DEG'
- 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: MOVIE_SOUTH_DEG'
- call read_value_integer(MOVIE_START, 'solver.MOVIE_START')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_START'
- call read_value_integer(MOVIE_STOP, 'solver.MOVIE_STOP')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_STOP'
- call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: SAVE_MESH_FILES'
- call read_value_integer(NUMBER_OF_RUNS, 'solver.NUMBER_OF_RUNS')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NUMBER_OF_RUNS'
- 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: NUMBER_OF_THIS_RUN'
- call read_value_string(LOCAL_PATH, 'LOCAL_PATH')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: LOCAL_PATH'
- 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: NTSTEP_BETWEEN_OUTPUT_INFO'
- 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: NTSTEP_BETWEEN_OUTPUT_SEISMOS'
- 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: OUTPUT_SIESMOS_ASCII_TEXT'
- 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: OUTPUT_SEISMOS_SAC_ALPHANUM'
- 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: OUTPUT_SEISMOS_SAC_BINARY'
- call read_value_logical(ROTATE_SEISMOGRAMS_RT, 'solver.ROTATE_SEISMOGRAMS_RT')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: ROTATE_SEISMOGRAMS_RT'
- 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: WRITE_SEISMOGRAMS_BY_MASTER'
- 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: SAVE_ALL_SEISMOS_IN_ONE_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: USE_BINARY_FOR_LARGE_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: RECEIVERS_CAN_BE_BURIED'
- 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: PRINT_SOURCE_TIME_FUNCTION'
-
- ! closes parameter file
- call close_parameter_file()
-
- end subroutine read_parameter_file
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/read_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_value_parameters.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_value_parameters.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,180 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! 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
- integer ierr
- common /param_err_common/ ierr
-
- call param_read(string_read, len(string_read), name, len(name), ierr);
- if (ierr .ne. 0) return
- 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
- integer ierr
- common /param_err_common/ ierr
-
- call param_read(string_read, len(string_read), name, len(name), ierr);
- if (ierr .ne. 0) return
- 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
- integer ierr
- common /param_err_common/ ierr
-
- call param_read(string_read, len(string_read), name, len(name), ierr);
- if (ierr .ne. 0) return
- 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=150) string_read
- integer ierr
- common /param_err_common/ ierr
-
- call param_read(string_read, len(string_read), name, len(name), ierr);
- if (ierr .ne. 0) return
- value_to_read = string_read
-
- end subroutine read_value_string
-
-!--------------------
-
- subroutine open_parameter_file
-
- integer ierr
- common /param_err_common/ ierr
- character(len=50) filename
- filename = 'DATA/Par_file'
-
- call param_open(filename, len(filename), ierr);
- if (ierr .ne. 0) return
-
- end subroutine open_parameter_file
-
-!--------------------
-
- subroutine close_parameter_file
-
- call param_close();
-
- end subroutine close_parameter_file
-
-!--------------------
-
- integer function err_occurred()
-
- integer ierr
- common /param_err_common/ ierr
-
- err_occurred = ierr
-
- end function err_occurred
-
-!--------------------
-
-!
-! unused routines:
-!
-
-! 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
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/recompute_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/recompute_jacobian.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/recompute_jacobian.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! 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/reduce.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/reduce.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/reduce.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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/rthetaphi_xyz.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/rthetaphi_xyz.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/rthetaphi_xyz.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,122 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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*xmesh + ymesh*ymesh + zmesh*zmesh))
-
- 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*xmesh + ymesh*ymesh + zmesh*zmesh)
-
- 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*xmesh + ymesh*ymesh + zmesh*zmesh)
-
- 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/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/save_arrays_solver.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/save_arrays_solver.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,440 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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,dvpstore, &
- 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,is_on_a_slice_edge,rmass,rmass_ocean_load,npointot_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,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,OCEANS, &
- tau_s,tau_e_store,Qmu_store,T_c_source,ATTENUATION,vx,vy,vz,vnspec, &
- ABSORBING_CONDITIONS,SAVE_MESH_FILES)
-
-
- implicit none
-
- include "constants.h"
-
-! model_attenuation_variables
-! type model_attenuation_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
-! 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, dimension(:), pointer :: interval_Q ! Steps
-! integer :: Qn ! Number of points
-! integer dummy_pad ! padding 4 bytes to align the structure
-! end type model_attenuation_variables
-
- logical ATTENUATION
-
- character(len=150) prname
- integer iregion_code
-
- integer nspec,nglob,nspec_stacey
- integer npointot_oceans
-
-! Stacey
- real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey)
- real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
-
- logical TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS
-
-! arrays with jacobian matrix
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
-! arrays with mesh parameters
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! for anisotropy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
-
- integer nspec_ani
- 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
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
-! doubling mesh flag
- integer, dimension(nspec) :: idoubling
-
-! this for non blocking MPI
- logical, dimension(nspec) :: is_on_a_slice_edge
-
-! mass matrix
- real(kind=CUSTOM_REAL) rmass(nglob)
-
-! additional ocean load mass matrix
- real(kind=CUSTOM_REAL) rmass_ocean_load(npointot_oceans)
-
-! boundary parameters locator
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
-
- 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)
-
-! normals
- 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)
-
-! jacobian on 2D edges
- 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)
-
-! number of elements on the boundaries
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
-
-! attenuation
- integer vx, vy, vz, vnspec
- double precision T_c_source
- double precision, dimension(N_SLS) :: tau_s
- double precision, dimension(vx, vy, vz, vnspec) :: Qmu_store
- double precision, dimension(N_SLS, vx, vy, vz, vnspec) :: tau_e_store
-
- logical ABSORBING_CONDITIONS,SAVE_MESH_FILES
-
- ! local parameters
- integer i,j,k,ispec,iglob,nspec1, nglob1
- real(kind=CUSTOM_REAL) scaleval1,scaleval2
-
-! save nspec and nglob, to be used in combine_paraview_data
- open(unit=27,file=prname(1:len_trim(prname))//'array_dims.txt',status='unknown',action='write')
-
- nspec1 = nspec
- nglob1 = nglob
-
- ! might be wrong, check...
- !if (NCHUNKS == 6 .and. ichunk /= CHUNK_AB .and. iregion_code == IREGION_INNER_CORE) then
- ! ! only chunk_AB contains inner core?
- ! ratio_divide_central_cube = 16
- ! ! corrects nspec/nglob
- ! nspec1 = nspec1 - (NEX_PER_PROC_XI/ratio_divide_central_cube) &
- ! * (NEX_PER_PROC_ETA/ratio_divide_central_cube) * (NEX_XI/ratio_divide_central_cube)
- ! nglob1 = nglob1 - ((NEX_PER_PROC_XI/ratio_divide_central_cube)*(NGLLX-1)+1) &
- ! * ((NEX_PER_PROC_ETA/ratio_divide_central_cube)*(NGLLY-1)+1) &
- ! * (NEX_XI/ratio_divide_central_cube)*(NGLLZ-1)
- !endif
-
- write(27,*) nspec1
- write(27,*) nglob1
- close(27)
-
- open(unit=27,file=prname(1:len_trim(prname))//'solver_data_1.bin',status='unknown',form='unformatted',action='write')
-
- write(27) xixstore
- write(27) xiystore
- write(27) xizstore
- write(27) etaxstore
- write(27) etaystore
- write(27) etazstore
- write(27) gammaxstore
- write(27) gammaystore
- write(27) gammazstore
-
- write(27) rhostore
- write(27) kappavstore
-
- if(HETEROGEN_3D_MANTLE) then
- open(unit=29,file=prname(1:len_trim(prname))//'dvp.bin',status='unknown',form='unformatted',action='write')
- write(29) dvpstore
- close(29)
- endif
-
-! other terms needed in the solid regions only
- if(iregion_code /= IREGION_OUTER_CORE) then
-
- if(.not. (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) write(27) muvstore
-
-! save anisotropy in the mantle only
- if(TRANSVERSE_ISOTROPY) then
- if(iregion_code == IREGION_CRUST_MANTLE .and. .not. ANISOTROPIC_3D_MANTLE) then
- write(27) kappahstore
- write(27) muhstore
- write(27) eta_anisostore
- endif
- endif
-
-! save anisotropy in the inner core only
- if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
- write(27) c11store
- write(27) c33store
- write(27) c12store
- write(27) c13store
- write(27) c44store
- endif
-
-
-
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
- write(27) c11store
- write(27) c12store
- write(27) c13store
- write(27) c14store
- write(27) c15store
- write(27) c16store
- write(27) c22store
- write(27) c23store
- write(27) c24store
- write(27) c25store
- write(27) c26store
- write(27) c33store
- write(27) c34store
- write(27) c35store
- write(27) c36store
- write(27) c44store
- write(27) c45store
- write(27) c46store
- write(27) c55store
- write(27) c56store
- write(27) c66store
- endif
-
- endif
-
-! Stacey
- if(ABSORBING_CONDITIONS) then
-
- if(iregion_code == IREGION_CRUST_MANTLE) then
- write(27) rho_vp
- write(27) rho_vs
- else if(iregion_code == IREGION_OUTER_CORE) then
- write(27) rho_vp
- endif
-
- endif
-
-! mass matrix
- write(27) rmass
-
-! additional ocean load mass matrix if oceans and if we are in the crust
- if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) write(27) rmass_ocean_load
-
- close(27)
-
- open(unit=27,file=prname(1:len_trim(prname))//'solver_data_2.bin',status='unknown',form='unformatted',action='write')
-! mesh arrays used in the solver to locate source and receivers
-! and for anisotropy and gravity, save in single precision
-! use rmass for temporary storage to perform conversion, since already saved
-
-!--- x coordinate
- rmass(:) = 0._CUSTOM_REAL
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglob) = sngl(xstore(i,j,k,ispec))
- else
- rmass(iglob) = xstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
- write(27) rmass
-
-!--- y coordinate
- rmass(:) = 0._CUSTOM_REAL
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglob) = sngl(ystore(i,j,k,ispec))
- else
- rmass(iglob) = ystore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
- write(27) rmass
-
-!--- z coordinate
- rmass(:) = 0._CUSTOM_REAL
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglob) = sngl(zstore(i,j,k,ispec))
- else
- rmass(iglob) = zstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
- write(27) rmass
-
- write(27) ibool
-
- write(27) idoubling
-
- write(27) is_on_a_slice_edge
-
- close(27)
-
-! absorbing boundary parameters
- open(unit=27,file=prname(1:len_trim(prname))//'boundary.bin',status='unknown',form='unformatted',action='write')
-
- write(27) nspec2D_xmin
- write(27) nspec2D_xmax
- write(27) nspec2D_ymin
- write(27) nspec2D_ymax
- write(27) NSPEC2D_BOTTOM
- write(27) NSPEC2D_TOP
-
- write(27) ibelm_xmin
- write(27) ibelm_xmax
- write(27) ibelm_ymin
- write(27) ibelm_ymax
- write(27) ibelm_bottom
- write(27) ibelm_top
-
- write(27) normal_xmin
- write(27) normal_xmax
- write(27) normal_ymin
- write(27) normal_ymax
- write(27) normal_bottom
- write(27) normal_top
-
- write(27) jacobian2D_xmin
- write(27) jacobian2D_xmax
- write(27) jacobian2D_ymin
- write(27) jacobian2D_ymax
- write(27) jacobian2D_bottom
- write(27) jacobian2D_top
-
- close(27)
-
-!> Hejun
-! No matter 1D or 3D Attenuation, we save value for gll points
- if(ATTENUATION) then
- open(unit=27, file=prname(1:len_trim(prname))//'attenuation.bin', status='unknown', form='unformatted',action='write')
- write(27) tau_s
- write(27) tau_e_store
- write(27) Qmu_store
- write(27) T_c_source
- close(27)
- endif
-
- ! uncomment for vp & vs model storage
- if( SAVE_MESH_FILES ) then
- scaleval1 = sngl( sqrt(PI*GRAV*RHOAV)*(R_EARTH/1000.0d0) )
- scaleval2 = sngl( RHOAV/1000.0d0 )
-
- ! isotropic model
- ! vp
- open(unit=27,file=prname(1:len_trim(prname))//'vp.bin',status='unknown',form='unformatted',action='write')
- write(27) sqrt( (kappavstore+4.*muvstore/3.)/rhostore )*scaleval1
- close(27)
- ! vs
- open(unit=27,file=prname(1:len_trim(prname))//'vs.bin',status='unknown',form='unformatted',action='write')
- write(27) sqrt( muvstore/rhostore )*scaleval1
- close(27)
- ! rho
- open(unit=27,file=prname(1:len_trim(prname))//'rho.bin',status='unknown',form='unformatted',action='write')
- write(27) rhostore*scaleval2
- close(27)
-
- ! transverse isotropic model
- if( TRANSVERSE_ISOTROPY ) then
- ! vpv
- open(unit=27,file=prname(1:len_trim(prname))//'vpv.bin',status='unknown',form='unformatted',action='write')
- write(27) sqrt( (kappavstore+4.*muvstore/3.)/rhostore )*scaleval1
- close(27)
- ! vph
- open(unit=27,file=prname(1:len_trim(prname))//'vph.bin',status='unknown',form='unformatted',action='write')
- write(27) sqrt( (kappahstore+4.*muhstore/3.)/rhostore )*scaleval1
- close(27)
- ! vsv
- open(unit=27,file=prname(1:len_trim(prname))//'vsv.bin',status='unknown',form='unformatted',action='write')
- write(27) sqrt( muvstore/rhostore )*scaleval1
- close(27)
- ! vsh
- open(unit=27,file=prname(1:len_trim(prname))//'vsh.bin',status='unknown',form='unformatted',action='write')
- write(27) sqrt( muhstore/rhostore )*scaleval1
- close(27)
- ! rho
- open(unit=27,file=prname(1:len_trim(prname))//'rho.bin',status='unknown',form='unformatted',action='write')
- write(27) rhostore*scaleval2
- close(27)
- ! eta
- open(unit=27,file=prname(1:len_trim(prname))//'eta.bin',status='unknown',form='unformatted',action='write')
- write(27) eta_anisostore
- close(27)
- endif
-
- endif
-
- end subroutine save_arrays_solver
-
-
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/save_forward_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/save_forward_arrays.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/save_forward_arrays.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,122 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine save_forward_arrays(myrank,SIMULATION_TYPE,SAVE_FORWARD, &
- NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
- displ_inner_core,veloc_inner_core,accel_inner_core, &
- displ_outer_core,veloc_outer_core,accel_outer_core, &
- R_memory_crust_mantle,R_memory_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
- A_array_rotation,B_array_rotation, &
- LOCAL_PATH)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- integer SIMULATION_TYPE
- logical SAVE_FORWARD
- integer NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
- displ_inner_core,veloc_inner_core,accel_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
- displ_outer_core,veloc_outer_core,accel_outer_core
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: &
- R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
- R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: &
- epsilondev_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
- A_array_rotation,B_array_rotation
-
- character(len=150) LOCAL_PATH
-
- ! local parameters
- character(len=150) outputname
-
-
- ! save files to local disk or tape system if restart file
- if(NUMBER_OF_RUNS > 1 .and. NUMBER_OF_THIS_RUN < NUMBER_OF_RUNS) then
- write(outputname,"('dump_all_arrays',i6.6)") myrank
- open(unit=55,file=trim(LOCAL_PATH)//'/'//outputname,status='unknown',form='unformatted',action='write')
- write(55) displ_crust_mantle
- write(55) veloc_crust_mantle
- write(55) accel_crust_mantle
- write(55) displ_inner_core
- write(55) veloc_inner_core
- write(55) accel_inner_core
- write(55) displ_outer_core
- write(55) veloc_outer_core
- write(55) accel_outer_core
- write(55) epsilondev_crust_mantle
- write(55) epsilondev_inner_core
- write(55) A_array_rotation
- write(55) B_array_rotation
- write(55) R_memory_crust_mantle
- write(55) R_memory_inner_core
- close(55)
- endif
-
- ! save last frame of the forward simulation
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- write(outputname,'(a,i6.6,a)') 'proc',myrank,'_save_forward_arrays.bin'
- open(unit=55,file=trim(LOCAL_PATH)//'/'//outputname,status='unknown',form='unformatted',action='write')
- write(55) displ_crust_mantle
- write(55) veloc_crust_mantle
- write(55) accel_crust_mantle
- write(55) displ_inner_core
- write(55) veloc_inner_core
- write(55) accel_inner_core
- write(55) displ_outer_core
- write(55) veloc_outer_core
- write(55) accel_outer_core
- write(55) epsilondev_crust_mantle
- write(55) epsilondev_inner_core
- if (ROTATION_VAL) then
- write(55) A_array_rotation
- write(55) B_array_rotation
- endif
- if (ATTENUATION_VAL) then
- write(55) R_memory_crust_mantle
- write(55) R_memory_inner_core
- endif
- close(55)
- endif
-
- end subroutine save_forward_arrays
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/save_header_file.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/save_header_file.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,529 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! 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,OCEANS,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, &
- SIMULATION_TYPE,SAVE_FORWARD,MOVIE_VOLUME)
-
- 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,OCEANS,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
-
- integer :: SIMULATION_TYPE
- logical :: SAVE_FORWARD,MOVIE_VOLUME
-
-
-! 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% or 90%'
- write(IOUT,*) '! of the memory installed per core)'
- 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(OCEANS) then
- write(IOUT,*) 'logical, parameter :: OCEANS_VAL = .true.'
- else
- write(IOUT,*) 'logical, parameter :: OCEANS_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 = ', &
- max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE))
-
- 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
- stop 'error nchunks in save_header_file()'
- 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
- att1 = NGLLX
- att2 = NGLLY
- att3 = NGLLZ
- att4 = NSPEC(IREGION_CRUST_MANTLE)
- att5 = NSPEC(IREGION_INNER_CORE)
- 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
-
- ! deville routines only implemented for NGLLX = NGLLY = NGLLZ = 5
- if( NGLLX == 5 .and. NGLLY == 5 .and. NGLLZ == 5 ) then
- write(IOUT,*) 'logical, parameter :: USE_DEVILLE_PRODUCTS_VAL = .true.'
- else
- write(IOUT,*) 'logical, parameter :: USE_DEVILLE_PRODUCTS_VAL = .false.'
- endif
-
- ! backward/reconstruction of forward wavefield:
- ! can only mimic attenuation effects on velocity at this point, since no full wavefield snapshots are stored
- if((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then
-
- ! attenuation mimic:
- ! mimicking effect of attenuation on apparent velocities, not amplitudes. that is,
- ! phase shifts should be correctly accounted for, but amplitudes will differ in adjoint simulations
- if( ATTENUATION ) then
- write(IOUT,*) 'logical, parameter :: USE_ATTENUATION_MIMIC = .true.'
- else
- write(IOUT,*) 'logical, parameter :: USE_ATTENUATION_MIMIC = .false.'
- endif
-
- else
-
- ! calculates full attenuation (phase & amplitude effects) if used
- write(IOUT,*) 'logical, parameter :: USE_ATTENUATION_MIMIC = .false.'
- endif
-
- ! attenuation and/or adjoint simulations
- if (ATTENUATION .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD &
- .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
- write(IOUT,*) 'logical, parameter :: COMPUTE_AND_STORE_STRAIN = .true. '
- else
- write(IOUT,*) 'logical, parameter :: COMPUTE_AND_STORE_STRAIN = .false.'
- endif
-
-
-
- close(IOUT)
-
- end subroutine save_header_file
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/save_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/save_kernels.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/save_kernels.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,801 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
- subroutine save_kernels_crust_mantle(myrank,scale_t,scale_displ, &
- cijkl_kl_crust_mantle,rho_kl_crust_mantle, &
- alpha_kl_crust_mantle,beta_kl_crust_mantle, &
- ystore_crust_mantle,zstore_crust_mantle, &
- rhostore_crust_mantle,muvstore_crust_mantle, &
- kappavstore_crust_mantle,ibool_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle, &
- eta_anisostore_crust_mantle,idoubling_crust_mantle, &
- LOCAL_PATH)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- double precision :: scale_t,scale_displ
-
- real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- cijkl_kl_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- rho_kl_crust_mantle, beta_kl_crust_mantle, alpha_kl_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
- ystore_crust_mantle,zstore_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
- rhostore_crust_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
-
- integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- character(len=150) LOCAL_PATH
-
- ! local parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- mu_kl_crust_mantle, kappa_kl_crust_mantle, rhonotprime_kl_crust_mantle
- real(kind=CUSTOM_REAL),dimension(21) :: cijkl_kl_local
- real(kind=CUSTOM_REAL) :: scale_kl,scale_kl_ani,scale_kl_rho
- real(kind=CUSTOM_REAL) :: rhol,mul,kappal,rho_kl,alpha_kl,beta_kl
- integer :: ispec,i,j,k,iglob
- character(len=150) prname
-
- ! transverse isotropic parameters
- real(kind=CUSTOM_REAL), dimension(21) :: an_kl
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: &
- alphav_kl_crust_mantle,alphah_kl_crust_mantle, &
- betav_kl_crust_mantle,betah_kl_crust_mantle, &
- eta_kl_crust_mantle
-
- ! bulk parameterization
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: &
- bulk_c_kl_crust_mantle,bulk_beta_kl_crust_mantle, &
- bulk_betav_kl_crust_mantle,bulk_betah_kl_crust_mantle
- real(kind=CUSTOM_REAL) :: A,C,F,L,N,eta
- real(kind=CUSTOM_REAL) :: muvl,kappavl,muhl,kappahl
- real(kind=CUSTOM_REAL) :: alphav_sq,alphah_sq,betav_sq,betah_sq,bulk_sq
-
- ! scaling factors
- scale_kl = scale_t/scale_displ * 1.d9
- ! For anisotropic kernels
- ! final unit : [s km^(-3) GPa^(-1)]
- scale_kl_ani = scale_t**3 / (RHOAV*R_EARTH**3) * 1.d18
- ! final unit : [s km^(-3) (kg/m^3)^(-1)]
- scale_kl_rho = scale_t / scale_displ / RHOAV * 1.d9
-
- ! allocates temporary arrays
- if( SAVE_TRANSVERSE_KL ) then
- ! transverse isotropic kernel arrays for file output
- allocate(alphav_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- alphah_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- betav_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- betah_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- eta_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT))
-
- ! isotropic kernel arrays for file output
- allocate(bulk_c_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- bulk_betav_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- bulk_betah_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- bulk_beta_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT))
- endif
-
- if( .not. ANISOTROPIC_KL ) then
- ! allocates temporary isotropic kernel arrays for file output
- allocate(bulk_c_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- bulk_beta_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT))
- endif
-
- ! crust_mantle
- do ispec = 1, NSPEC_CRUST_MANTLE
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
-
-
- if (ANISOTROPIC_KL) then
-
- ! For anisotropic kernels
- iglob = ibool_crust_mantle(i,j,k,ispec)
-
- ! The cartesian global cijkl_kl are rotated into the spherical local cijkl_kl
- ! ystore and zstore are thetaval and phival (line 2252) -- dangerous
- call rotate_kernels_dble(cijkl_kl_crust_mantle(:,i,j,k,ispec),cijkl_kl_local, &
- ystore_crust_mantle(iglob),zstore_crust_mantle(iglob))
-
- cijkl_kl_crust_mantle(:,i,j,k,ispec) = cijkl_kl_local * scale_kl_ani
- rho_kl_crust_mantle(i,j,k,ispec) = rho_kl_crust_mantle(i,j,k,ispec) * scale_kl_rho
-
- ! transverse isotropic kernel calculations
- if( SAVE_TRANSVERSE_KL ) then
- ! note: transverse isotropic kernels are calculated for all elements
- !
- ! however, the factors A,C,L,N,F are based only on transverse elements
- ! in between Moho and 220 km layer, otherwise they are taken from isotropic values
-
- rhol = rhostore_crust_mantle(i,j,k,ispec)
-
- ! transverse isotropic parameters from compute_force_crust_mantle.f90
- ! C=rhovpvsq A=rhovphsq L=rhovsvsq N=rhovshsq eta=F/(A - 2 L)
-
- ! Get A,C,F,L,N,eta from kappa,mu
- ! element can have transverse isotropy if between d220 and Moho
- if( .not. (TRANSVERSE_ISOTROPY_VAL .and. &
- (idoubling_crust_mantle(ispec) == IFLAG_80_MOHO .or. &
- idoubling_crust_mantle(ispec) == IFLAG_220_80))) then
-
- ! layer with no transverse isotropy
- ! A,C,L,N,F from isotropic model
-
- mul = muvstore_crust_mantle(i,j,k,ispec)
- kappal = kappavstore_crust_mantle(i,j,k,ispec)
- muvl = mul
- muhl = mul
- kappavl = kappal
- kappahl = kappal
-
- A = kappal + FOUR_THIRDS * mul
- C = A
- L = mul
- N = mul
- F = kappal - 2._CUSTOM_REAL/3._CUSTOM_REAL * mul
- eta = 1._CUSTOM_REAL
-
- else
-
- ! A,C,L,N,F from transverse isotropic model
- kappavl = kappavstore_crust_mantle(i,j,k,ispec)
- kappahl = kappahstore_crust_mantle(i,j,k,ispec)
- muvl = muvstore_crust_mantle(i,j,k,ispec)
- muhl = muhstore_crust_mantle(i,j,k,ispec)
- kappal = kappavl
-
- A = kappahl + FOUR_THIRDS * muhl
- C = kappavl + FOUR_THIRDS * muvl
- L = muvl
- N = muhl
- eta = eta_anisostore_crust_mantle(i,j,k,ispec) ! that is F / (A - 2 L)
- F = eta * ( A - 2._CUSTOM_REAL * L )
-
- endif
-
- ! note: cijkl_kl_local() is fully anisotropic C_ij kernel components (non-dimensionalized)
- ! for GLL point at (i,j,k,ispec)
-
- ! Purpose : compute the kernels for the An coeffs (an_kl)
- ! from the kernels for Cij (cijkl_kl_local)
- ! At r,theta,phi fixed
- ! kernel def : dx = kij * dcij + krho * drho
- ! = kAn * dAn + krho * drho
-
- ! Definition of the input array cij_kl :
- ! cij_kl(1) = C11 ; cij_kl(2) = C12 ; cij_kl(3) = C13
- ! cij_kl(4) = C14 ; cij_kl(5) = C15 ; cij_kl(6) = C16
- ! cij_kl(7) = C22 ; cij_kl(8) = C23 ; cij_kl(9) = C24
- ! cij_kl(10) = C25 ; cij_kl(11) = C26 ; cij_kl(12) = C33
- ! cij_kl(13) = C34 ; cij_kl(14) = C35 ; cij_kl(15) = C36
- ! cij_kl(16) = C44 ; cij_kl(17) = C45 ; cij_kl(18) = C46
- ! cij_kl(19) = C55 ; cij_kl(20) = C56 ; cij_kl(21) = C66
- ! where the Cij (Voigt's notation) are defined as function of
- ! the components of the elastic tensor in spherical coordinates
- ! by eq. (A.1) of Chen & Tromp, GJI 168 (2007)
-
- ! From the relations giving Cij in function of An
- ! Checked with Min Chen's results (routine build_cij)
-
- an_kl(1) = cijkl_kl_local(1)+cijkl_kl_local(2)+cijkl_kl_local(7) !A
- an_kl(2) = cijkl_kl_local(12) !C
- an_kl(3) = -2*cijkl_kl_local(2)+cijkl_kl_local(21) !N
- an_kl(4) = cijkl_kl_local(16)+cijkl_kl_local(19) !L
- an_kl(5) = cijkl_kl_local(3)+cijkl_kl_local(8) !F
-
- ! not used yet
- !an_kl(6)=2*cijkl_kl_local(5)+2*cijkl_kl_local(10)+2*cijkl_kl_local(14) !Jc
- !an_kl(7)=2*cijkl_kl_local(4)+2*cijkl_kl_local(9)+2*cijkl_kl_local(13) !Js
- !an_kl(8)=-2*cijkl_kl_local(14) !Kc
- !an_kl(9)=-2*cijkl_kl_local(13) !Ks
- !an_kl(10)=-2*cijkl_kl_local(10)+cijkl_kl_local(18) !Mc
- !an_kl(11)=2*cijkl_kl_local(4)-cijkl_kl_local(20) !Ms
- !an_kl(12)=cijkl_kl_local(1)-cijkl_kl_local(7) !Bc
- !an_kl(13)=-1./2.*(cijkl_kl_local(6)+cijkl_kl_local(11)) !Bs
- !an_kl(14)=cijkl_kl_local(3)-cijkl_kl_local(8) !Hc
- !an_kl(15)=-cijkl_kl_local(15) !Hs
- !an_kl(16)=-cijkl_kl_local(16)+cijkl_kl_local(19) !Gc
- !an_kl(17)=-cijkl_kl_local(17) !Gs
- !an_kl(18)=cijkl_kl_local(5)-cijkl_kl_local(10)-cijkl_kl_local(18) !Dc
- !an_kl(19)=cijkl_kl_local(4)-cijkl_kl_local(9)+cijkl_kl_local(20) !Ds
- !an_kl(20)=cijkl_kl_local(1)-cijkl_kl_local(2)+cijkl_kl_local(7)-cijkl_kl_local(21) !Ec
- !an_kl(21)=-cijkl_kl_local(6)+cijkl_kl_local(11) !Es
-
- ! K_rho (primary kernel, for a parameterization (A,C,L,N,F,rho) )
- rhonotprime_kl_crust_mantle(i,j,k,ispec) = rhol * rho_kl_crust_mantle(i,j,k,ispec) / scale_kl_rho
-
- ! note: transverse isotropic kernels are calculated for ALL elements,
- ! and not just transverse elements
- !
- ! note: the kernels are for relative perturbations (delta ln (m_i) = (m_i - m_0)/m_i )
- !
- ! Gets transverse isotropic kernels
- ! (see Appendix B of Sieminski et al., GJI 171, 2007)
-
- ! for parameterization: ( alpha_v, alpha_h, beta_v, beta_h, eta, rho )
- ! K_alpha_v
- alphav_kl_crust_mantle(i,j,k,ispec) = 2*C*an_kl(2)
- ! K_alpha_h
- alphah_kl_crust_mantle(i,j,k,ispec) = 2*A*an_kl(1) + 2*A*eta*an_kl(5)
- ! K_beta_v
- betav_kl_crust_mantle(i,j,k,ispec) = 2*L*an_kl(4) - 4*L*eta*an_kl(5)
- ! K_beta_h
- betah_kl_crust_mantle(i,j,k,ispec) = 2*N*an_kl(3)
- ! K_eta
- eta_kl_crust_mantle(i,j,k,ispec) = F*an_kl(5)
- ! K_rhoprime (for a parameterization (alpha_v, ..., rho) )
- rho_kl_crust_mantle(i,j,k,ispec) = A*an_kl(1) + C*an_kl(2) &
- + N*an_kl(3) + L*an_kl(4) + F*an_kl(5) &
- + rhonotprime_kl_crust_mantle(i,j,k,ispec)
-
- ! write the kernel in physical units (01/05/2006)
- rhonotprime_kl_crust_mantle(i,j,k,ispec) = - rhonotprime_kl_crust_mantle(i,j,k,ispec) * scale_kl
-
- alphav_kl_crust_mantle(i,j,k,ispec) = - alphav_kl_crust_mantle(i,j,k,ispec) * scale_kl
- alphah_kl_crust_mantle(i,j,k,ispec) = - alphah_kl_crust_mantle(i,j,k,ispec) * scale_kl
- betav_kl_crust_mantle(i,j,k,ispec) = - betav_kl_crust_mantle(i,j,k,ispec) * scale_kl
- betah_kl_crust_mantle(i,j,k,ispec) = - betah_kl_crust_mantle(i,j,k,ispec) * scale_kl
- eta_kl_crust_mantle(i,j,k,ispec) = - eta_kl_crust_mantle(i,j,k,ispec) * scale_kl
- rho_kl_crust_mantle(i,j,k,ispec) = - rho_kl_crust_mantle(i,j,k,ispec) * scale_kl
-
- ! for parameterization: ( bulk, beta_v, beta_h, eta, rho )
- ! where kappa_v = kappa_h = kappa and bulk c = sqrt( kappa / rho )
- betav_sq = muvl / rhol
- betah_sq = muhl / rhol
- alphav_sq = ( kappal + FOUR_THIRDS * muvl ) / rhol
- alphah_sq = ( kappal + FOUR_THIRDS * muhl ) / rhol
- bulk_sq = kappal / rhol
-
- bulk_c_kl_crust_mantle(i,j,k,ispec) = &
- bulk_sq / alphav_sq * alphav_kl_crust_mantle(i,j,k,ispec) + &
- bulk_sq / alphah_sq * alphah_kl_crust_mantle(i,j,k,ispec)
-
- bulk_betah_kl_crust_mantle(i,j,k,ispec ) = &
- betah_kl_crust_mantle(i,j,k,ispec) + &
- FOUR_THIRDS * betah_sq / alphah_sq * alphah_kl_crust_mantle(i,j,k,ispec)
-
- bulk_betav_kl_crust_mantle(i,j,k,ispec ) = &
- betav_kl_crust_mantle(i,j,k,ispec) + &
- FOUR_THIRDS * betav_sq / alphav_sq * alphav_kl_crust_mantle(i,j,k,ispec)
- ! the rest, K_eta and K_rho are the same as above
-
- ! to check: isotropic kernels from transverse isotropic ones
- alpha_kl_crust_mantle(i,j,k,ispec) = alphav_kl_crust_mantle(i,j,k,ispec) &
- + alphah_kl_crust_mantle(i,j,k,ispec)
- beta_kl_crust_mantle(i,j,k,ispec) = betav_kl_crust_mantle(i,j,k,ispec) &
- + betah_kl_crust_mantle(i,j,k,ispec)
- !rho_kl_crust_mantle(i,j,k,ispec) = rhonotprime_kl_crust_mantle(i,j,k,ispec) &
- ! + alpha_kl_crust_mantle(i,j,k,ispec) &
- ! + beta_kl_crust_mantle(i,j,k,ispec)
- bulk_beta_kl_crust_mantle(i,j,k,ispec) = bulk_betah_kl_crust_mantle(i,j,k,ispec ) &
- + bulk_betav_kl_crust_mantle(i,j,k,ispec )
-
- endif ! SAVE_TRANSVERSE_KL
-
- else
-
- ! isotropic kernels
-
- rhol = rhostore_crust_mantle(i,j,k,ispec)
- mul = muvstore_crust_mantle(i,j,k,ispec)
- kappal = kappavstore_crust_mantle(i,j,k,ispec)
-
- ! kernel values for rho, kappa, mu (primary kernel values)
- rho_kl = - rhol * rho_kl_crust_mantle(i,j,k,ispec)
- alpha_kl = - kappal * alpha_kl_crust_mantle(i,j,k,ispec) ! note: alpha_kl corresponds to K_kappa
- beta_kl = - 2 * mul * beta_kl_crust_mantle(i,j,k,ispec) ! note: beta_kl corresponds to K_mu
-
- ! for a parameterization: (rho,mu,kappa) "primary" kernels
- rhonotprime_kl_crust_mantle(i,j,k,ispec) = rho_kl * scale_kl
- mu_kl_crust_mantle(i,j,k,ispec) = beta_kl * scale_kl
- kappa_kl_crust_mantle(i,j,k,ispec) = alpha_kl * scale_kl
-
- ! for a parameterization: (rho,alpha,beta)
- ! kernels rho^prime, beta, alpha
- rho_kl_crust_mantle(i,j,k,ispec) = (rho_kl + alpha_kl + beta_kl) * scale_kl
- beta_kl_crust_mantle(i,j,k,ispec) = &
- 2._CUSTOM_REAL * (beta_kl - FOUR_THIRDS * mul * alpha_kl / kappal) * scale_kl
- alpha_kl_crust_mantle(i,j,k,ispec) = &
- 2._CUSTOM_REAL * (1 + FOUR_THIRDS * mul / kappal) * alpha_kl * scale_kl
-
- ! for a parameterization: (rho,bulk, beta)
- ! where bulk wave speed is c = sqrt( kappa / rho)
- ! note: rhoprime is the same as for (rho,alpha,beta) parameterization
- bulk_c_kl_crust_mantle(i,j,k,ispec) = 2._CUSTOM_REAL * alpha_kl * scale_kl
- bulk_beta_kl_crust_mantle(i,j,k,ispec ) = 2._CUSTOM_REAL * beta_kl * scale_kl
-
- endif
-
- enddo
- enddo
- enddo
- enddo
-
- call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
-
- ! For anisotropic kernels
- if (ANISOTROPIC_KL) then
-
- ! outputs transverse isotropic kernels only
- if( SAVE_TRANSVERSE_KL ) then
- ! transverse isotropic kernels
- ! (alpha_v, alpha_h, beta_v, beta_h, eta, rho ) parameterization
- open(unit=27,file=trim(prname)//'alphav_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) alphav_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'alphah_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) alphah_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'betav_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) betav_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'betah_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) betah_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'eta_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) eta_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) rho_kl_crust_mantle
- close(27)
-
- ! in case one is interested in primary kernel K_rho
- !open(unit=27,file=trim(prname)//'rhonotprime_kernel.bin',status='unknown',form='unformatted',action='write')
- !write(27) rhonotprime_kl_crust_mantle
- !close(27)
-
- ! (bulk, beta_v, beta_h, eta, rho ) parameterization: K_eta and K_rho same as above
- open(unit=27,file=trim(prname)//'bulk_c_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) bulk_c_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'bulk_betav_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) bulk_betav_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'bulk_betah_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) bulk_betah_kl_crust_mantle
- close(27)
-
- ! to check: isotropic kernels
- open(unit=27,file=trim(prname)//'alpha_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) alpha_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'beta_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) beta_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'bulk_beta_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) bulk_beta_kl_crust_mantle
- close(27)
-
- else
-
- ! fully anisotropic kernels
- ! note: the C_ij and density kernels are not for relative perturbations (delta ln( m_i) = delta m_i / m_i),
- ! but absolute perturbations (delta m_i = m_i - m_0)
- open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) - rho_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'cijkl_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) - cijkl_kl_crust_mantle
- close(27)
-
- endif
-
- else
- ! primary kernels: (rho,kappa,mu) parameterization
- open(unit=27,file=trim(prname)//'rhonotprime_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) rhonotprime_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'kappa_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) kappa_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'mu_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) mu_kl_crust_mantle
- close(27)
-
- ! (rho, alpha, beta ) parameterization
- open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) rho_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'alpha_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) alpha_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'beta_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) beta_kl_crust_mantle
- close(27)
-
- ! (rho, bulk, beta ) parameterization, K_rho same as above
- open(unit=27,file=trim(prname)//'bulk_c_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) bulk_c_kl_crust_mantle
- close(27)
- open(unit=27,file=trim(prname)//'bulk_beta_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) bulk_beta_kl_crust_mantle
- close(27)
-
-
- endif
-
- ! cleans up temporary kernel arrays
- if( SAVE_TRANSVERSE_KL ) then
- deallocate(alphav_kl_crust_mantle,alphah_kl_crust_mantle, &
- betav_kl_crust_mantle,betah_kl_crust_mantle, &
- eta_kl_crust_mantle)
- deallocate(bulk_c_kl_crust_mantle,bulk_betah_kl_crust_mantle, &
- bulk_betav_kl_crust_mantle,bulk_beta_kl_crust_mantle)
- endif
- if( .not. ANISOTROPIC_KL ) then
- deallocate(bulk_c_kl_crust_mantle,bulk_beta_kl_crust_mantle)
- endif
-
- end subroutine save_kernels_crust_mantle
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine save_kernels_outer_core(myrank,scale_t,scale_displ, &
- rho_kl_outer_core,alpha_kl_outer_core, &
- rhostore_outer_core,kappavstore_outer_core, &
- deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
- LOCAL_PATH)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- double precision :: scale_t,scale_displ
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: &
- rho_kl_outer_core,alpha_kl_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
- rhostore_outer_core,kappavstore_outer_core
-
- integer nspec_beta_kl_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_beta_kl_outer_core) :: &
- beta_kl_outer_core
- logical deviatoric_outercore
-
- character(len=150) LOCAL_PATH
-
- ! local parameters
- real(kind=CUSTOM_REAL):: scale_kl
- real(kind=CUSTOM_REAL) :: rhol,kappal,rho_kl,alpha_kl,beta_kl
- integer :: ispec,i,j,k
- character(len=150) prname
-
- scale_kl = scale_t/scale_displ * 1.d9
-
- ! outer_core
- do ispec = 1, NSPEC_OUTER_CORE
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- rhol = rhostore_outer_core(i,j,k,ispec)
- kappal = kappavstore_outer_core(i,j,k,ispec)
- rho_kl = - rhol * rho_kl_outer_core(i,j,k,ispec)
- alpha_kl = - kappal * alpha_kl_outer_core(i,j,k,ispec)
-
- rho_kl_outer_core(i,j,k,ispec) = (rho_kl + alpha_kl) * scale_kl
- alpha_kl_outer_core(i,j,k,ispec) = 2 * alpha_kl * scale_kl
-
-
- !deviatoric kernel check
- if( deviatoric_outercore ) then
- beta_kl = - 2 * beta_kl_outer_core(i,j,k,ispec) ! not using mul, since it's zero for the fluid
- beta_kl_outer_core(i,j,k,ispec) = beta_kl
- endif
-
- enddo
- enddo
- enddo
- enddo
-
- call create_name_database(prname,myrank,IREGION_OUTER_CORE,LOCAL_PATH)
- open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) rho_kl_outer_core
- close(27)
- open(unit=27,file=trim(prname)//'alpha_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) alpha_kl_outer_core
- close(27)
-
- !deviatoric kernel check
- if( deviatoric_outercore ) then
- open(unit=27,file=trim(prname)//'mu_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) beta_kl_outer_core
- close(27)
- endif
-
- end subroutine save_kernels_outer_core
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine save_kernels_inner_core(myrank,scale_t,scale_displ, &
- rho_kl_inner_core,beta_kl_inner_core,alpha_kl_inner_core, &
- rhostore_inner_core,muvstore_inner_core,kappavstore_inner_core, &
- LOCAL_PATH)
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- double precision :: scale_t,scale_displ
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- rho_kl_inner_core, beta_kl_inner_core, alpha_kl_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
- rhostore_inner_core, kappavstore_inner_core,muvstore_inner_core
-
- character(len=150) LOCAL_PATH
-
- ! local parameters
- real(kind=CUSTOM_REAL):: scale_kl
- real(kind=CUSTOM_REAL) :: rhol,mul,kappal,rho_kl,alpha_kl,beta_kl
- integer :: ispec,i,j,k
- character(len=150) prname
-
-
- scale_kl = scale_t/scale_displ * 1.d9
-
- ! inner_core
- do ispec = 1, NSPEC_INNER_CORE
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- rhol = rhostore_inner_core(i,j,k,ispec)
- mul = muvstore_inner_core(i,j,k,ispec)
- kappal = kappavstore_inner_core(i,j,k,ispec)
-
- rho_kl = -rhol * rho_kl_inner_core(i,j,k,ispec)
- alpha_kl = -kappal * alpha_kl_inner_core(i,j,k,ispec)
- beta_kl = - 2 * mul * beta_kl_inner_core(i,j,k,ispec)
-
- rho_kl_inner_core(i,j,k,ispec) = (rho_kl + alpha_kl + beta_kl) * scale_kl
- beta_kl_inner_core(i,j,k,ispec) = 2 * (beta_kl - FOUR_THIRDS * mul * alpha_kl / kappal) * scale_kl
- alpha_kl_inner_core(i,j,k,ispec) = 2 * (1 + FOUR_THIRDS * mul / kappal) * alpha_kl * scale_kl
- enddo
- enddo
- enddo
- enddo
-
- call create_name_database(prname,myrank,IREGION_INNER_CORE,LOCAL_PATH)
- open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) rho_kl_inner_core
- close(27)
- open(unit=27,file=trim(prname)//'alpha_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) alpha_kl_inner_core
- close(27)
- open(unit=27,file=trim(prname)//'beta_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) beta_kl_inner_core
- close(27)
-
- end subroutine save_kernels_inner_core
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine save_kernels_boundary_kl(myrank,scale_t,scale_displ, &
- moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl, &
- LOCAL_PATH,HONOR_1D_SPHERICAL_MOHO)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- double precision :: scale_t,scale_displ
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO) :: moho_kl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_400) :: d400_kl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_670) :: d670_kl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_CMB) :: cmb_kl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_ICB) :: icb_kl
-
- character(len=150) LOCAL_PATH
-
- logical HONOR_1D_SPHERICAL_MOHO
-
- ! local parameters
- real(kind=CUSTOM_REAL):: scale_kl
- character(len=150) prname
-
-
- scale_kl = scale_t/scale_displ * 1.d9
-
- ! scale the boundary kernels properly: *scale_kl gives s/km^3 and 1.d3 gives
- ! the relative boundary kernels (for every 1 km) in s/km^2
- moho_kl = moho_kl * scale_kl * 1.d3
- d400_kl = d400_kl * scale_kl * 1.d3
- d670_kl = d670_kl * scale_kl * 1.d3
- cmb_kl = cmb_kl * scale_kl * 1.d3
- icb_kl = icb_kl * scale_kl * 1.d3
-
- call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
-
- if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
- open(unit=27,file=trim(prname)//'moho_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) moho_kl
- close(27)
- endif
-
- open(unit=27,file=trim(prname)//'d400_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) d400_kl
- close(27)
-
- open(unit=27,file=trim(prname)//'d670_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) d670_kl
- close(27)
-
- open(unit=27,file=trim(prname)//'CMB_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) cmb_kl
- close(27)
-
- call create_name_database(prname,myrank,IREGION_OUTER_CORE,LOCAL_PATH)
-
- open(unit=27,file=trim(prname)//'ICB_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) icb_kl
- close(27)
-
-
- end subroutine save_kernels_boundary_kl
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine save_kernels_source_derivatives(nrec_local,NSOURCES,scale_displ,scale_t, &
- nu_source,moment_der,sloc_der,stshift_der,shdur_der,number_receiver_global)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer nrec_local,NSOURCES
- double precision :: scale_displ,scale_t
-
- double precision :: nu_source(NDIM,NDIM,NSOURCES)
- real(kind=CUSTOM_REAL) :: moment_der(NDIM,NDIM,nrec_local),sloc_der(NDIM,nrec_local), &
- stshift_der(nrec_local),shdur_der(nrec_local)
-
- integer, dimension(nrec_local) :: number_receiver_global
-
- ! local parameters
- real(kind=CUSTOM_REAL),parameter :: scale_mass = RHOAV * (R_EARTH**3)
- integer :: irec_local
- character(len=150) outputname
-
- !scale_mass = RHOAV * (R_EARTH**3)
-
- do irec_local = 1, nrec_local
- ! rotate and scale the location derivatives to correspond to dn,de,dz
- sloc_der(:,irec_local) = matmul(transpose(nu_source(:,:,irec_local)),sloc_der(:,irec_local)) &
- * scale_displ * scale_t
-
- ! rotate scale the moment derivatives to correspond to M[n,e,z][n,e,z]
- moment_der(:,:,irec_local) = matmul(matmul(transpose(nu_source(:,:,irec_local)),moment_der(:,:,irec_local)),&
- nu_source(:,:,irec_local)) * scale_t ** 3 / scale_mass
-
- ! derivatives for time shift and hduration
- stshift_der(irec_local) = stshift_der(irec_local) * scale_displ**2
- shdur_der(irec_local) = shdur_der(irec_local) * scale_displ**2
-
- write(outputname,'(a,i5.5)') 'OUTPUT_FILES/src_frechet.',number_receiver_global(irec_local)
- open(unit=27,file=trim(outputname),status='unknown',action='write')
- !
- ! r -> z, theta -> -n, phi -> e, plus factor 2 for Mrt,Mrp,Mtp, and 1e-7 to dyne.cm
- ! Mrr = Mzz
- ! Mtt = Mnn
- ! Mpp = Mee
- ! Mrt = -Mzn
- ! Mrp = Mze
- ! Mtp = -Mne
- ! for consistency, location derivatives are in the order of [Xr,Xt,Xp]
- ! minus sign for sloc_der(3,irec_local) to get derivative for depth instead of radius
-
- write(27,'(g16.5)') moment_der(3,3,irec_local) * 1e-7
- write(27,'(g16.5)') moment_der(1,1,irec_local) * 1e-7
- write(27,'(g16.5)') moment_der(2,2,irec_local) * 1e-7
- write(27,'(g16.5)') -2*moment_der(1,3,irec_local) * 1e-7
- write(27,'(g16.5)') 2*moment_der(2,3,irec_local) * 1e-7
- write(27,'(g16.5)') -2*moment_der(1,2,irec_local) * 1e-7
- write(27,'(g16.5)') sloc_der(2,irec_local)
- write(27,'(g16.5)') sloc_der(1,irec_local)
- write(27,'(g16.5)') -sloc_der(3,irec_local)
- write(27,'(g16.5)') stshift_der(irec_local)
- write(27,'(g16.5)') shdur_der(irec_local)
- close(27)
- enddo
-
-
- end subroutine save_kernels_source_derivatives
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine save_kernels_hessian(myrank,scale_t,scale_displ, &
- hess_kl_crust_mantle,LOCAL_PATH)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank
-
- double precision :: scale_t,scale_displ
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- hess_kl_crust_mantle
-
- character(len=150) LOCAL_PATH
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: scale_kl
- character(len=150) prname
-
- ! scaling factors
- scale_kl = scale_t/scale_displ * 1.d9
-
- ! scales approximate hessian
- hess_kl_crust_mantle(:,:,:,:) = 2._CUSTOM_REAL * hess_kl_crust_mantle(:,:,:,:) * scale_kl
-
- ! stores into file
- call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
- open(unit=27,file=trim(prname)//'hess_kernel.bin',status='unknown',form='unformatted',action='write')
- write(27) hess_kl_crust_mantle
- close(27)
-
- end subroutine save_kernels_hessian
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/setup/config.h.in (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/config.h.in)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/setup/config.h.in (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/setup/config.h.in 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,33 @@
+/* config.h.in. Generated from configure.ac by autoheader. */
+
+/* Define to dummy `main' function (if any) required to link to the Fortran
+ libraries. */
+#undef FC_DUMMY_MAIN
+
+/* Define if F77 and FC dummy `main' functions are identical. */
+#undef FC_DUMMY_MAIN_EQ_F77
+
+/* Define to a macro mangling the given C identifier (in lower and upper
+ case), which must not contain underscores, for linking with Fortran. */
+#undef FC_FUNC
+
+/* As FC_FUNC, but for C identifiers containing underscores. */
+#undef FC_FUNC_
+
+/* Define to the address where bug reports for this package should be sent. */
+#undef PACKAGE_BUGREPORT
+
+/* Define to the full name of this package. */
+#undef PACKAGE_NAME
+
+/* Define to the full name and version of this package. */
+#undef PACKAGE_STRING
+
+/* Define to the one symbol short name of this package. */
+#undef PACKAGE_TARNAME
+
+/* Define to the version of this package. */
+#undef PACKAGE_VERSION
+
+/* Uncomment to select optimized file i/o for regional simulations */
+/* #define USE_MAP_FUNCTION */
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/setup/constants.h.in (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/constants.h.in)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/setup/constants.h.in (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/setup/constants.h.in 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,582 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! March 2010
+!
+! 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.
+!
+!=====================================================================
+
+! @configure_input@
+
+!
+!--- user can modify parameters below
+!
+
+!
+! 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 = @CUSTOM_REAL@
+
+! this for non blocking assembly
+ logical, parameter :: USE_NONBLOCKING_COMMS = .true.
+ integer, parameter :: ELEMENTS_NONBLOCKING_CM_IC = 1500
+ integer, parameter :: ELEMENTS_NONBLOCKING_OC = 3000
+
+! if files on a local path on each node are also seen as global with same path
+! set to .true. typically on a shared-memory machine with a common file system
+! set to .false. typically on a cluster of nodes with local disks
+! if running on a cluster of nodes with local disks, also customize global path
+! to local files in create_serial_name_database.f90 ("20 format ...")
+! Flag is used only when one checks the mesh with the serial codes
+! ("xcheck_buffers_1D" etc.), ignore it if you do not plan to use them
+ logical, parameter :: LOCAL_PATH_IS_ALSO_GLOBAL = . at LOCAL_PATH_IS_ALSO_GLOBAL@.
+
+! input, output and main MPI I/O files
+ integer, parameter :: ISTANDARD_OUTPUT = 6
+ integer, parameter :: IIN = 40,IOUT = 41,IOUT_SAC = 903
+ integer, parameter :: IIN_NOISE = 43,IOUT_NOISE = 44
+! 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
+! I/O unit for source and receiver vtk file
+ integer, parameter :: IOVTK = 98
+
+
+! 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'
+
+!!--- ETOPO1 1-minute model, implemented now, but data file must be created first
+!! size of topography and bathymetry file
+! integer, parameter :: NX_BATHY = 21600,NY_BATHY = 10800
+!! resolution of topography file in minutes
+! integer, parameter :: RESOLUTION_TOPO_FILE = 1
+!! pathname of the topography file (un-smoothed)
+! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/ETOPO1.xyz'
+
+! Use GLL points to capture TOPOGRAPHY and ELLIPTICITY (experimental feature)
+ logical,parameter :: USE_GLL = .false.
+
+! 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
+
+!-- crustal models
+ integer, parameter :: ICRUST_CRUST2 = 1
+ integer, parameter :: ICRUST_CRUSTMAPS = 2
+
+! increase smoothing for critical regions (increases mesh stability)
+ logical, parameter :: SMOOTH_CRUST = .true.
+
+! use sedimentary layers in crustal model
+ logical, parameter :: INCLUDE_SEDIMENTS_CRUST = .true.
+ double precision, parameter :: MINIMUM_SEDIMENT_THICKNESS = 2.d0 ! minimim thickness in km
+
+!-- uncomment for using Crust2.0 (used when CRUSTAL flag is set for simulation)
+ integer, parameter :: ITYPE_CRUSTAL_MODEL = ICRUST_CRUST2
+!!-- uncomment for using General Crustmaps instead
+!! integer, parameter :: ITYPE_CRUSTAL_MODEL = ICRUST_CRUSTMAPS
+
+! 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
+
+! use a force source located exactly at a grid point instead of a CMTSOLUTION source
+! this can be useful e.g. for asteroid impact simulations
+! in which the source is a vertical force, normal force, impact etc.
+ logical, parameter :: USE_FORCE_POINT_SOURCE = .false.
+ double precision, parameter :: FACTOR_FORCE_SOURCE = 1.d15
+ integer, parameter :: COMPONENT_FORCE_SOURCE = 3 ! takes direction in comp E/N/Z = 1/2/3
+
+! use this t0 as earliest starting time rather than the automatically calculated one
+! (must be positive and bigger than the automatically one to be effective;
+! simulation will start at t = - t0)
+ double precision, parameter :: USER_T0 = 0.0d0
+
+! 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.
+
+! output only transverse isotropic kernels (alpha_v,alpha_h,beta_v,beta_h,eta,rho)
+! rather than fully anisotropic kernels in case ANISOTROPIC_KL is set to .true.
+ logical, parameter :: SAVE_TRANSVERSE_KL = .false.
+
+! output approximate hessian in crust mantle region
+ logical, parameter :: APPROXIMATE_HESS_KL = .false.
+
+! output kernel mask to zero out source region
+ logical,parameter :: SAVE_SOURCE_MASK = .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.
+
+! flag to turn off the conversion of geographic to geocentric coordinates for
+! the seismic source and the stations; i.e. assume a perfect sphere, which
+! can be useful for benchmarks of a spherical Earth with fictitious sources and stations
+ logical, parameter :: ASSUME_PERFECT_SPHERE = .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
+
+! Deville routines optimized for NGLLX = NGLLY = NGLLZ = 5
+ integer, parameter :: m1 = NGLLX, m2 = NGLLX * NGLLY
+
+! 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_1DREF = 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
+ integer, parameter :: THREE_D_MODEL_PPM = 9 ! format for point profile models
+ integer, parameter :: THREE_D_MODEL_GLL = 10 ! format for iterations with GLL mesh
+ integer, parameter :: THREE_D_MODEL_S40RTS = 11
+ integer, parameter :: THREE_D_MODEL_GAPP2 = 12
+
+! 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, was 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, was 4
+
+! number of slaves per corner
+ integer, parameter :: NUMSLAVES = 2
+
+! 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 = 136
+
+! 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 = 20,NS_20 = 20,NS_40 = 40, ND = 1
+
+! heterogen_mantle_model_constants
+ integer, parameter :: N_R = 256,N_THETA = 256,N_PHI = 256
+
+! 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
+
+!QRFSI12 constants
+ integer,parameter :: NKQ=8,MAXL_Q=12
+ integer,parameter :: NSQ=(MAXL_Q+1)**2,NDEPTHS_REFQ=913
+
+! 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
+
+! General Crustmaps parameters
+ integer, parameter :: CRUSTMAP_RESOLUTION = 4 !means 1/4 degrees
+ integer, parameter :: NLAYERS_CRUSTMAP = 5
+
+!!!!!!!!!!!!!! end of parameters added for the thread-safe version of the code
+
+! for the stretching of crustal elements in the case of 3D models
+! (values are chosen for 3D models to have RMOHO_FICTICIOUS at 35 km
+! and RMIDDLE_CRUST to become 15 km with stretching function stretch_tab)
+ double precision, parameter :: MAX_RATIO_CRUST_STRETCHING = 0.75d0
+ double precision, parameter :: RMOHO_STRETCH_ADJUSTEMENT = 5000.d0 ! moho up to 35km
+ double precision, parameter :: R80_STRETCH_ADJUSTEMENT = -40000.d0 ! r80 down to 120km
+
+! adapted regional moho stretching
+! 1 chunk simulations, 3-layer crust
+ logical, parameter :: REGIONAL_MOHO_MESH = .false.
+ logical, parameter :: REGIONAL_MOHO_MESH_EUROPE = .false. ! used only for fixing time step
+ logical, parameter :: REGIONAL_MOHO_MESH_ASIA = .false. ! used only for fixing time step
+ logical, parameter :: HONOR_DEEP_MOHO = .false.
+! uncomment for e.g. Europe case, where deep moho is rare
+!! double precision, parameter :: RMOHO_STRETCH_ADJUSTEMENT = -15000.d0 ! moho mesh boundary down to 55km
+! uncomment for deep moho cases, e.g. Asia case (Himalayan moho)
+!! double precision, parameter :: RMOHO_STRETCH_ADJUSTEMENT = -20000.d0 ! moho mesh boundary down to 60km
+
+
+! 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 inflate the central cube (set to 0.d0 for a non-inflated cube)
+ double precision, parameter :: CENTRAL_CUBE_INFLATE_FACTOR = 0.41d0
+
+! 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
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/setup/precision.h.in (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/precision.h.in)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/setup/precision.h.in (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/setup/precision.h.in 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! March 2010
+!
+! 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.
+!
+!=====================================================================
+
+! @configure_input@
+
+!
+! 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 = @CUSTOM_MPI_TYPE@
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/setup_sources_receivers.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/setup_sources_receivers.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,593 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine setup_sources_receivers(NSOURCES,myrank,ibool_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xigll,yigll,zigll,TOPOGRAPHY, &
- sec,tshift_cmt,theta_source,phi_source, &
- NSTEP,DT,hdur,hdur_gaussian,t0,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, &
- rec_filename,nrec,islice_selected_rec,ispec_selected_rec, &
- xi_receiver,eta_receiver,gamma_receiver,station_name,network_name, &
- stlat,stlon,stele,stbur,nu, &
- nrec_local,nadj_rec_local,nrec_simulation, &
- SIMULATION_TYPE,RECEIVERS_CAN_BE_BURIED,MOVIE_SURFACE,MOVIE_VOLUME, &
- HDUR_MOVIE,OUTPUT_FILES,LOCAL_PATH)
-
-
- implicit none
-
- include 'mpif.h'
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer NSOURCES,myrank
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
-
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLY) :: yigll
- double precision, dimension(NGLLZ) :: zigll
-
- logical TOPOGRAPHY
-
- double precision sec,DT,t0,min_tshift_cmt_original
-
- double precision, dimension(NSOURCES) :: tshift_cmt,hdur,hdur_gaussian
- double precision, dimension(NSOURCES) :: theta_source,phi_source
- double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source,nu_source
-
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
- integer NSTEP
-
- ! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
- integer NEX_XI
- logical PRINT_SOURCE_TIME_FUNCTION
-
- character(len=150) rec_filename
-
- integer nrec
- integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
-
- double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- double precision, dimension(nrec) :: stlat,stlon,stele,stbur
- double precision, dimension(NDIM,NDIM,nrec) :: nu
-
- integer nrec_local,nadj_rec_local,nrec_simulation
-
- integer SIMULATION_TYPE
-
- logical RECEIVERS_CAN_BE_BURIED,MOVIE_SURFACE,MOVIE_VOLUME
-
- double precision HDUR_MOVIE
-
- character(len=150) OUTPUT_FILES
- character(len=150) LOCAL_PATH
-
- ! local parameters
- double precision :: junk
- integer :: yr,jda,ho,mi
- integer :: irec,isource,nrec_tot_found,ier
- integer :: icomp,itime,nadj_files_found,nadj_files_found_tot
- character(len=3),dimension(NDIM) :: comp
- character(len=150) :: filename,adj_source_file,system_command,filename_new
- character(len=2) :: bic
-
-! sources
- ! BS BS moved open statement and writing of first lines into sr.vtk before the
- ! call to locate_sources, where further write statements to that file follow
- if(myrank == 0) then
- ! write source and receiver VTK files for Paraview
- filename = trim(OUTPUT_FILES)//'/sr_tmp.vtk'
- open(IOVTK,file=trim(filename),status='unknown')
- write(IOVTK,'(a)') '# vtk DataFile Version 2.0'
- write(IOVTK,'(a)') 'Source and Receiver VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- ! LQY -- won't be able to know NSOURCES+nrec at this point...
- write(IOVTK, '(a,i6,a)') 'POINTS ', NSOURCES, ' float'
- 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_VAL,ELLIPTICITY_VAL,TOPOGRAPHY, &
- sec,tshift_cmt,min_tshift_cmt_original,yr,jda,ho,mi,theta_source,phi_source, &
- NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- islice_selected_source,ispec_selected_source, &
- xi_source,eta_source,gamma_source, nu_source, &
- rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION, &
- LOCAL_PATH,SIMULATION_TYPE)
-
- if(abs(minval(tshift_cmt)) > TINYVAL) call exit_MPI(myrank,'one tshift_cmt must be zero, others must be positive')
-
- ! filter source time function by Gaussian with hdur = HDUR_MOVIE when outputing movies or shakemaps
- if (MOVIE_SURFACE .or. MOVIE_VOLUME ) then
- hdur = sqrt(hdur**2 + HDUR_MOVIE**2)
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'Each source is being convolved with HDUR_MOVIE = ',HDUR_MOVIE
- write(IMAIN,*)
- endif
- endif
-
- ! convert the half duration for triangle STF to the one for gaussian STF
- hdur_gaussian(:) = hdur(:)/SOURCE_DECAY_MIMIC_TRIANGLE
-
- ! define t0 as the earliest start time
- t0 = - 1.5d0*minval( tshift_cmt(:) - hdur(:) )
-
- ! point force sources will start depending on the frequency given by hdur
- if( USE_FORCE_POINT_SOURCE ) then
- ! note: point force sources will give the dominant frequency in hdur,
- ! thus the main period is 1/hdur.
- ! also, these sources use a Ricker source time function instead of a gaussian.
- ! for a Ricker source time function, a start time ~1.2 * main_period is a good choice
- t0 = - 1.2d0 * minval(tshift_cmt(:) - 1.0d0/hdur(:))
- endif
-
- ! checks if user set USER_T0 to fix simulation start time
- ! note: USER_T0 has to be positive
- if( USER_T0 > 0.d0 ) then
- ! user cares about origin time and time shifts of the CMTSOLUTION
- ! and wants to fix simulation start time to a constant start time
- ! time 0 on time axis will correspond to given origin time
-
- ! notifies user
- if( myrank == 0 ) then
- write(IMAIN,*) 'USER_T0: ',USER_T0
- write(IMAIN,*) 't0: ',t0,'min_tshift_cmt_original: ',min_tshift_cmt_original
- write(IMAIN,*)
- endif
-
- ! checks if automatically set t0 is too small
- ! note: min_tshift_cmt_original can be a positive or negative time shift (minimum from all tshift)
- if( t0 <= USER_T0 + min_tshift_cmt_original ) then
- ! by default, tshift_cmt(:) holds relative time shifts with a minimum time shift set to zero
- ! re-adds (minimum) original time shift such that sources will kick in
- ! according to their absolute time shift
- tshift_cmt(:) = tshift_cmt(:) + min_tshift_cmt_original
-
- ! sets new simulation start time such that
- ! simulation starts at t = - t0 = - USER_T0
- t0 = USER_T0
-
- ! notifies user
- if( myrank == 0 ) then
- write(IMAIN,*) ' set new simulation start time: ', - t0
- write(IMAIN,*)
- endif
- else
- ! start time needs to be at least t0 for numerical stability
- ! notifies user
- if( myrank == 0 ) then
- write(IMAIN,*) 'error: USER_T0 is too small'
- write(IMAIN,*) ' must make one of three adjustements:'
- write(IMAIN,*) ' - increase USER_T0 to be at least: ',t0-min_tshift_cmt_original
- write(IMAIN,*) ' - decrease time shift in CMTSOLUTION file'
- write(IMAIN,*) ' - decrease hdur in CMTSOLUTION file'
- endif
- call exit_mpi(myrank,'error USER_T0 is set but too small')
- endif
- else if( USER_T0 < 0.d0 ) then
- if( myrank == 0 ) then
- write(IMAIN,*) 'error: USER_T0 is negative, must be set zero or positive!'
- endif
- call exit_mpi(myrank,'error negative USER_T0 parameter in constants.h')
- endif
-
- ! receivers
- if(myrank == 0) then
- write(IMAIN,*)
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- write(IMAIN,*) 'Total number of receivers = ', nrec
- else
- write(IMAIN,*) 'Total number of adjoint sources = ', nrec
- endif
- write(IMAIN,*)
- 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,stbur,nu, &
- yr,jda,ho,mi,sec,NPROCTOT_VAL,ELLIPTICITY_VAL,TOPOGRAPHY, &
- theta_source(1),phi_source(1),rspl,espl,espl2,nspl, &
- ibathy_topo,RECEIVERS_CAN_BE_BURIED,NCHUNKS_VAL)
-
-
- ! count number of receivers located in this slice
- nrec_local = 0
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- nrec_simulation = nrec
- do irec = 1,nrec
- if(myrank == islice_selected_rec(irec)) nrec_local = nrec_local + 1
- enddo
- else
- nrec_simulation = NSOURCES
- do isource = 1, NSOURCES
- if(myrank == islice_selected_source(isource)) nrec_local = nrec_local + 1
- enddo
- endif
-
- ! counts receivers for adjoint simulations
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- ! by Ebru
- call band_instrument_code(DT,bic)
- comp(1) = bic(1:2)//'N'
- comp(2) = bic(1:2)//'E'
- comp(3) = bic(1:2)//'Z'
-
- ! counter for adjoint receiver stations in local slice, used to allocate adjoint source arrays
- nadj_rec_local = 0
- ! temporary counter to check if any files are found at all
- nadj_files_found = 0
- do irec = 1,nrec
- if(myrank == islice_selected_rec(irec))then
- ! adjoint receiver station in this process slice
- if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROCTOT_VAL-1) &
- call exit_MPI(myrank,'something is wrong with the source slice number in adjoint simulation')
-
- ! updates counter
- nadj_rec_local = nadj_rec_local + 1
-
- ! checks **sta**.**net**.**MX**.adj files for correct number of time steps
- adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
- do icomp = 1,NDIM
-
- ! opens adjoint source file for this component
- filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
- open(unit=IIN,file=trim(filename),status='old',action='read',iostat=ier)
-
- if( ier == 0 ) then
- ! checks length of file
- itime = 0
- do while(ier == 0)
- read(IIN,*,iostat=ier) junk,junk
- if( ier == 0 ) itime = itime + 1
- enddo
- if( itime /= NSTEP) &
- call exit_MPI(myrank,&
- 'file '//trim(filename)//' has wrong length, please check with your simulation duration')
-
- ! updates counter for found files
- nadj_files_found = nadj_files_found + 1
- else
- ! adjoint source file not found
- ! stops simulation
- call exit_MPI(myrank,&
- 'file '//trim(filename)//' not found, please check with your STATIONS_ADJOINT file')
- endif
- close(IIN)
- enddo
- endif
- enddo
-
- ! checks if any adjoint source files found at all
- call MPI_REDUCE(nadj_files_found,nadj_files_found_tot,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
- if( myrank == 0 ) then
- write(IMAIN,*)
- write(IMAIN,*) ' ',nadj_files_found_tot,' adjoint component traces found in all slices'
- if(nadj_files_found_tot == 0) &
- call exit_MPI(myrank,'no adjoint traces found, please check adjoint sources in directory SEM/')
- endif
- endif
-
- ! 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 slices'
- if(nrec_tot_found /= nrec_simulation) then
- call exit_MPI(myrank,'problem when dispatching the receivers')
- else
- write(IMAIN,*) 'this total is okay'
- endif
- endif
-
- ! user output
- if(myrank == 0) then
-
- ! finishes vtk file
- write(IOVTK,*) ""
- close(IOVTK)
-
- ! we should know NSOURCES+nrec at this point...
- filename = trim(OUTPUT_FILES)//'/sr_tmp.vtk'
- filename_new = trim(OUTPUT_FILES)//'/sr.vtk'
- write(system_command,"('sed -e ',a1,'s/POINTS.*/POINTS',i6,' float/',a1,' < ',a,' > ',a)") &
- "'",NSOURCES + nrec,"'",trim(filename),trim(filename_new)
- call system(system_command)
-
- write(IMAIN,*)
- write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP
- write(IMAIN,*)
-
-
- if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
- endif
-
- end subroutine setup_sources_receivers
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine setup_sources_receivers_srcarr(NSOURCES,myrank, &
- ispec_selected_source,islice_selected_source, &
- xi_source,eta_source,gamma_source, &
- Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- 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,sourcearrays)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer NSOURCES,myrank
-
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
-
- 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
-
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLY) :: yigll
- double precision, dimension(NGLLZ) :: zigll
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES) :: sourcearrays
-
-
- ! local parameters
- integer :: isource
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
-
- do isource = 1,NSOURCES
-
- ! check that the source slice number is okay
- if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROCTOT_VAL-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
-
- end subroutine setup_sources_receivers_srcarr
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine setup_sources_receivers_adjindx(NSTEP,NSTEP_SUB_ADJ, &
- NTSTEP_BETWEEN_READ_ADJSRC, &
- iadjsrc,iadjsrc_len,iadj_vec)
-
- implicit none
-
- include "constants.h"
-
- integer NSTEP,NSTEP_SUB_ADJ,NTSTEP_BETWEEN_READ_ADJSRC
-
- integer, dimension(NSTEP_SUB_ADJ,2) :: iadjsrc ! to read input in chunks
- integer, dimension(NSTEP_SUB_ADJ) :: iadjsrc_len
- integer, dimension(NSTEP) :: iadj_vec
-
-
- ! local parameters
- integer :: iadj_block,it,it_sub_adj
-
- iadj_block = 1 !counts blocks
-
- iadjsrc(:,:) = 0
- iadjsrc_len(:) = 0
-
- ! setting up chunks of NTSTEP_BETWEEN_READ_ADJSRC to read adjoint source traces
- ! i.e. as an example: total length NSTEP = 3000, chunk length NTSTEP_BETWEEN_READ_ADJSRC= 1000
- ! then it will set first block from 2001 to 3000,
- ! second block from 1001 to 2000 and so on...
- !
- ! see routine: compute_arrays_source_adjoint()
- ! how we read in the adjoint source trace in blocks/chunk sizes
- !
- ! see routine: compute_add_sources_adjoint()
- ! how the adjoint source is added to the (adjoint) acceleration field
- do it=1,NSTEP
-
- ! block number
- ! e.g. increases from 1 (case it=1-1000), 2 (case it=1001-2000) to 3 (case it=2001-3000)
- it_sub_adj = ceiling( dble(it)/dble(NTSTEP_BETWEEN_READ_ADJSRC) )
-
- ! we are at the edge of a block
- if(mod(it-1,NTSTEP_BETWEEN_READ_ADJSRC) == 0) then
- ! block start time ( e.g. 2001)
- iadjsrc(iadj_block,1) = NSTEP-it_sub_adj*NTSTEP_BETWEEN_READ_ADJSRC+1
- ! block end time (e.g. 3000)
- iadjsrc(iadj_block,2) = NSTEP-(it_sub_adj-1)*NTSTEP_BETWEEN_READ_ADJSRC
-
- ! final adj src array
- ! e.g. will be from 1000 to 1, but doesn't go below 1 in cases where NSTEP isn't
- ! a multiple of NTSTEP_BETWEEN_READ_ADJSRC
- if(iadjsrc(iadj_block,1) < 0) iadjsrc(iadj_block,1) = 1
-
- ! actual block length
- iadjsrc_len(iadj_block) = iadjsrc(iadj_block,2)-iadjsrc(iadj_block,1)+1
-
- ! increases block number
- iadj_block = iadj_block+1
- endif
-
- ! time stepping for adjoint sources:
- ! adjoint time step that corresponds to time step in simulation (it).
- ! note, that adjoint source has to be time-reversed with respect to the forward wavefield
- ! e.g.: first block 1 has iadjsrc_len = 1000 with start at 2001 and end at 3000
- ! so iadj_vec(1) = 1000 - 0, iadj_vec(2) = 1000 - 1, ..., to iadj_vec(1000) = 1000 - 999 = 1
- ! then for block 2, iadjsrc_len = 1000 with start at 1001 and end at 2000
- ! so iadj_vec(1001) = 1000 - 0, iad_vec(1002) = 1000 - 1, .. and so on again down to 1
- ! then block 3 and your guess is right now... iadj_vec(2001) to iadj_vec(3000) is 1000 down to 1. :)
- iadj_vec(it) = iadjsrc_len(it_sub_adj) - mod(it-1,NTSTEP_BETWEEN_READ_ADJSRC)
- enddo
-
- end subroutine setup_sources_receivers_adjindx
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine setup_sources_receivers_intp(NSOURCES,myrank, &
- islice_selected_source, &
- xi_source,eta_source,gamma_source, &
- xigll,yigll,zigll, &
- SIMULATION_TYPE,nrec,nrec_local, &
- islice_selected_rec,number_receiver_global, &
- xi_receiver,eta_receiver,gamma_receiver, &
- hxir_store,hetar_store,hgammar_store, &
- nadj_hprec_local,hpxir_store,hpetar_store,hpgammar_store)
-
- implicit none
-
- include "constants.h"
-
- integer NSOURCES,myrank
-
- integer, dimension(NSOURCES) :: islice_selected_source
-
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLY) :: yigll
- double precision, dimension(NGLLZ) :: zigll
-
-
- integer SIMULATION_TYPE
-
- integer nrec,nrec_local
- integer, dimension(nrec) :: islice_selected_rec
- integer, dimension(nrec_local) :: number_receiver_global
- double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
-
- double precision, dimension(nrec_local,NGLLX) :: hxir_store
- double precision, dimension(nrec_local,NGLLY) :: hetar_store
- double precision, dimension(nrec_local,NGLLZ) :: hgammar_store
-
- integer nadj_hprec_local
- double precision, dimension(nadj_hprec_local,NGLLX) :: hpxir_store
- double precision, dimension(nadj_hprec_local,NGLLY) :: hpetar_store
- double precision, dimension(nadj_hprec_local,NGLLZ) :: hpgammar_store
-
-
- ! local parameters
- integer :: isource,irec,irec_local
- double precision, dimension(NGLLX) :: hxir,hpxir
- double precision, dimension(NGLLY) :: hpetar,hetar
- double precision, dimension(NGLLZ) :: hgammar,hpgammar
-
-
- ! select local receivers
-
- ! define local to global receiver numbering mapping
- irec_local = 0
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- do irec = 1,nrec
- if(myrank == islice_selected_rec(irec)) then
- irec_local = irec_local + 1
- number_receiver_global(irec_local) = irec
- endif
- enddo
- else
- do isource = 1,NSOURCES
- if(myrank == islice_selected_source(isource)) then
- irec_local = irec_local + 1
- number_receiver_global(irec_local) = isource
- endif
- enddo
- endif
-
- ! define and store Lagrange interpolators at all the receivers
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- 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
- else
- do irec_local = 1,nrec_local
- irec = number_receiver_global(irec_local)
- call lagrange_any(xi_source(irec),NGLLX,xigll,hxir,hpxir)
- call lagrange_any(eta_source(irec),NGLLY,yigll,hetar,hpetar)
- call lagrange_any(gamma_source(irec),NGLLZ,zigll,hgammar,hpgammar)
- hxir_store(irec_local,:) = hxir(:)
- hetar_store(irec_local,:) = hetar(:)
- hgammar_store(irec_local,:) = hgammar(:)
- hpxir_store(irec_local,:) = hpxir(:)
- hpetar_store(irec_local,:) = hpetar(:)
- hpgammar_store(irec_local,:) = hpgammar(:)
- enddo
- endif
-
- end subroutine setup_sources_receivers_intp
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/sort_array_coordinates.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/sort_array_coordinates.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/sort_array_coordinates.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! 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/specfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/specfem3D.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/specfem3D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,4385 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-!
-! United States and French Government Sponsorship Acknowledged.
-
- program xspecfem3D
-
- 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 at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{VaCaSaKoVi99,
-! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
-! D. Komatitsch and J. P. Vilotte},
-! title = {Elastic wave propagation in an irregularly layered medium},
-! journal = {Soil Dynamics and Earthquake Engineering},
-! year = {1999},
-! volume = {18},
-! pages = {11-18},
-! number = {1},
-! doi = {10.1016/S0267-7261(98)00027-X}}
-!
-! @ARTICLE{LeChKoHuTr09,
-! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
-! Shouh Huang and Jeroen Tromp},
-! title = {Effects of realistic surface topography on seismic ground motion
-! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
-! method and {LiDAR DTM}},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {681-693},
-! number = {2A},
-! doi = {10.1785/0120080264}}
-!
-! @ARTICLE{LeChLiKoHuTr08,
-! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
-! and Bor Shouh Huang and Jeroen Tromp},
-! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
-! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2008},
-! volume = {98},
-! pages = {253-264},
-! number = {1},
-! doi = {10.1785/0120070033}}
-!
-! @ARTICLE{LeKoHuTr09,
-! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
-! title = {Effects of topography on seismic wave propagation: An example from
-! northern {T}aiwan},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {314-325},
-! number = {1},
-! doi = {10.1785/0120080020}}
-!
-! @ARTICLE{KoErGoMi10,
-! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
-! David Mich\'ea},
-! title = {High-order finite-element seismic wave propagation modeling with
-! {MPI} on a large {GPU} cluster},
-! journal = {J. Comput. Phys.},
-! year = {2010},
-! volume = {229},
-! pages = {7692-7714},
-! number = {20},
-! doi = {10.1016/j.jcp.2010.06.024}}
-!
-! @ARTICLE{KoGoErMi10,
-! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
-! David Mich\'ea},
-! title = {Modeling the propagation of elastic waves using spectral elements
-! on a cluster of 192 {GPU}s},
-! journal = {Computer Science Research and Development},
-! year = {2010},
-! volume = {25},
-! pages = {75-82},
-! number = {1-2},
-! doi = {10.1007/s00450-010-0109-1}}
-!
-! @ARTICLE{KoMiEr09,
-! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
-! title = {Porting a high-order finite-element earthquake modeling application
-! to {NVIDIA} graphics cards using {CUDA}},
-! journal = {Journal of Parallel and Distributed Computing},
-! year = {2009},
-! volume = {69},
-! pages = {451-460},
-! number = {5},
-! doi = {10.1016/j.jpdc.2009.01.006}}
-!
-! @INCOLLECTION{ChKoViCaVaFe07,
-! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
-! Yann Capdeville and Bernard Valette and Gaetano Festa},
-! title = {Spectral Element Analysis in Seismology},
-! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
-! publisher = {Elsevier - Academic Press},
-! year = {2007},
-! editor = {Ru-Shan Wu and Val\'erie Maupin},
-! volume = {48},
-! series = {Advances in Geophysics},
-! pages = {365-419}}
-!
-! @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}}
-!
-! @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{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}}
-!
-! and/or another article from http://web.univ-pau.fr/~dkomati1/publications.html
-!
-!
-! If you use the kernel capabilities of the code, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{LiTr06,
-! author={Qinya Liu and Jeroen Tromp},
-! title={Finite-frequency kernels based on adjoint methods},
-! journal={Bull. Seismol. Soc. Am.},
-! year=2006,
-! volume=96,
-! number=6,
-! pages={2383-2397},
-! doi={10.1785/0120060041}}
-!
-! If you use 3-D model S20RTS, please cite:
-!
-! @ARTICLE{RiVa00,
-! author={J. Ritsema and H. J. {Van Heijst}},
-! year=2000,
-! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
-! journal={Science Progress},
-! volume=83,
-! pages={243-259}}
-!
-! Reference frame - convention:
-! ----------------------------
-!
-! The code uses the following convention for the reference frame:
-!
-! - X axis is East
-! - Y axis is North
-! - Z axis is up
-!
-! Note that this convention is different from both the Aki-Richards convention
-! and the Harvard CMT convention.
-!
-! Let us recall that the Aki-Richards convention is:
-!
-! - X axis is North
-! - Y axis is East
-! - Z axis is down
-!
-! and that the Harvard CMT convention is:
-!
-! - X axis is South
-! - Y axis is East
-! - Z axis is up
-!
-! To report bugs or suggest improvements to the code, please send an email
-! to Jeroen Tromp <jtromp AT princeton.edu> and/or use our online
-! bug tracking system at http://www.geodynamics.org/roundup .
-!
-! Evolution of the code:
-! ---------------------
-!
-! v. 5.1, Dimitri Komatitsch, University of Toulouse, France and Ebru Bozdag, Princeton University, USA, February 2011:
-! non blocking MPI for much better scaling on large clusters;
-! new convention for the name of seismograms, to conform to the IRIS standard;
-! new directory structure
-!
-! v. 5.0 aka Tiger, many developers some with Princeton Tiger logo on their shirts, February 2010:
-! new moho mesh stretching honoring crust2.0 moho depths,
-! new attenuation assignment, new SAC headers, new general crustal models,
-! faster performance due to Deville routines and enhanced loop unrolling,
-! slight changes in code structure (see also trivia at program start)
-!
-! 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, one more doubling level at the bottom
-! of the outer core if needed (off by default)
-!
-! 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 CM-5 Connection Machine
-!
-! 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.
-
-! memory variables and standard linear solids for attenuation
- real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT4) :: one_minus_sum_beta_crust_mantle, factor_scale_crust_mantle
- real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT5) :: one_minus_sum_beta_inner_core, factor_scale_inner_core
-
- 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
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: epsilondev_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: eps_trace_over_3_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: epsilondev_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STRAIN_ONLY) :: eps_trace_over_3_inner_core
-
-! ADJOINT
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: b_alphaval, b_betaval, b_gammaval
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: b_R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: b_epsilondev_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: b_eps_trace_over_3_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: b_R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: b_epsilondev_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: b_eps_trace_over_3_inner_core
-
-! for matching with central cube in inner core
- integer, dimension(:), allocatable :: sender_from_slices_to_cube
- integer, dimension(:,:), allocatable :: ibool_central_cube
- double precision, dimension(:,:), allocatable :: buffer_slices,b_buffer_slices,buffer_slices2
- double precision, dimension(:,:,:), allocatable :: buffer_all_cube_from_slices,b_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
-
-! to save movie frames
- integer nmovie_points,NIT
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
- store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all
-
-! to save movie volume
- integer :: npoints_3dmovie,nspecel_3dmovie
- integer, dimension(NGLOB_CRUST_MANTLE) :: num_ibool_3dmovie
- double precision :: scalingval
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: muvstore_crust_mantle_3dmovie
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: nu_3dmovie
- logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: mask_3dmovie
-
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: Iepsilondev_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: Ieps_trace_over_3_crust_mantle
-
-! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
-! for crust/oceans coupling
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
- integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
-
-! additional mass matrix for ocean load
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
-
-! flag to mask ocean-bottom degrees of freedom for ocean load
- logical, dimension(NGLOB_CRUST_MANTLE_OCEANS) :: updated_dof_ocean_load
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: jacobian2D_bottom_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: jacobian2D_top_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: jacobian2D_xmin_crust_mantle,&
- jacobian2D_xmax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_CM) :: jacobian2D_ymin_crust_mantle,&
- jacobian2D_ymax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2DMAX_YMIN_YMAX_CM) :: &
- normal_ymin_crust_mantle,normal_ymax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: normal_bottom_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
-
-! Stacey
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: rho_vp_crust_mantle,rho_vs_crust_mantle
- integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle,nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_CM) :: nimin_crust_mantle,nimax_crust_mantle,nkmin_eta_crust_mantle
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_CM) :: njmin_crust_mantle,njmax_crust_mantle,nkmin_xi_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_STACEY) :: vp_outer_core
- integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core,nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_OC) :: nimin_outer_core,nimax_outer_core,nkmin_eta_outer_core
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_OC) :: njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core
-
-! arrays to couple with the fluid regions by pointwise matching
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
- integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
- integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: normal_xmin_outer_core,normal_xmax_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: normal_ymin_outer_core,normal_ymax_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core
-
-
- 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 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 NGLOB2DMAX_XY
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle, &
- iboolfaces_outer_core,iboolfaces_inner_core
-
-! this for non blocking MPI
-
-! 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
- integer :: npoin2D_max_all_CM_IC
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_send_faces,buffer_received_faces, &
- b_buffer_send_faces,b_buffer_received_faces
-
-! for non blocking communications
- logical, dimension(NSPEC_CRUST_MANTLE) :: is_on_a_slice_edge_crust_mantle
- logical, dimension(NSPEC_OUTER_CORE) :: is_on_a_slice_edge_outer_core
- logical, dimension(NSPEC_INNER_CORE) :: is_on_a_slice_edge_inner_core
- logical, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool
- real :: percentage_edge
-
-! assembling phase number for non blocking MPI
-! iphase is for the crust_mantle, outer_core and inner_core regions
-! iphase_CC is for the central cube
- integer :: iphase,iphase_CC,icall
- integer :: b_iphase,b_iphase_CC,b_icall
-
-! -------- 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) :: &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle
-
-! arrays for anisotropic elements stored only where needed to save space
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
-
-! arrays for full anisotropy only when needed
- 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, &
- 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
-
-! 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
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
- rhostore_outer_core,kappavstore_outer_core
-
-! local to global mapping
- integer, dimension(NSPEC_OUTER_CORE) :: idoubling_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, &
- rhostore_inner_core, kappavstore_inner_core,muvstore_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: &
- xstore_inner_core,ystore_inner_core,zstore_inner_core
-
-! arrays for inner-core anisotropy only when needed
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core
-
-! local to global mapping
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
-
-! mass matrix
- real(kind=CUSTOM_REAL), dimension(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_t_inv,scale_displ,scale_veloc
-
-! ADJOINT
- real(kind=CUSTOM_REAL) b_deltat,b_deltatover2,b_deltatsqover2
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: div_displ_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: b_div_displ_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: rho_kl_crust_mantle, &
- beta_kl_crust_mantle, alpha_kl_crust_mantle, Sigma_kl_crust_mantle
-! For anisotropic kernels (see compute_kernels.f90 for a definition of the array)
- real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: cijkl_kl_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: rho_kl_outer_core, &
- alpha_kl_outer_core
-
- ! approximate hessian
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: hess_kl_crust_mantle
-
- ! check for deviatoric kernel for outer core region
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: beta_kl_outer_core
- integer :: nspec_beta_kl_outer_core
- logical,parameter:: deviatoric_outercore = .false.
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: rho_kl_inner_core, &
- beta_kl_inner_core, alpha_kl_inner_core
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: absorb_xmin_crust_mantle5, &
- absorb_xmax_crust_mantle5, absorb_ymin_crust_mantle5, absorb_ymax_crust_mantle5
-
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: absorb_xmin_outer_core, &
- absorb_xmax_outer_core, absorb_ymin_outer_core, absorb_ymax_outer_core, &
- absorb_zmin_outer_core
- integer nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm
- integer nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc,nabs_zmin_oc
-
- integer reclen_xmin_crust_mantle, reclen_xmax_crust_mantle, reclen_ymin_crust_mantle, &
- reclen_ymax_crust_mantle, reclen_xmin_outer_core, reclen_xmax_outer_core,&
- reclen_ymin_outer_core, reclen_ymax_outer_core, reclen_zmin
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_OUTER_CORE) :: vector_accel_outer_core,&
- vector_displ_outer_core, b_vector_displ_outer_core
-
- 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
- integer, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
- double precision, dimension(:,:,:) ,allocatable:: nu_source
- double precision sec
- double precision, dimension(:), allocatable :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
- double precision, dimension(:), allocatable :: xi_source,eta_source,gamma_source
- double precision, dimension(:), allocatable :: tshift_cmt,hdur,hdur_gaussian
- double precision, dimension(:), allocatable :: theta_source,phi_source
- double precision, external :: comp_source_time_function
- double precision t0
-
-! receiver information
- integer nrec,nrec_local
- integer, dimension(:), allocatable :: islice_selected_rec,ispec_selected_rec,number_receiver_global
- double precision, dimension(:), allocatable :: xi_receiver,eta_receiver,gamma_receiver
- character(len=150) :: STATIONS,rec_filename
- double precision, dimension(:,:,:), allocatable :: nu
- double precision, allocatable, dimension(:) :: stlat,stlon,stele,stbur
- character(len=MAX_LENGTH_STATION_NAME), dimension(:), allocatable :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(:), allocatable :: network_name
-
-!ADJOINT
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: adj_sourcearrays
- integer nrec_simulation, nadj_rec_local
- integer NSTEP_SUB_ADJ ! to read input in chunks
- integer, dimension(:,:), allocatable :: iadjsrc ! to read input in chunks
- integer, dimension(:), allocatable :: iadjsrc_len,iadj_vec
-! source frechet derivatives
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: moment_der
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: sloc_der
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: stshift_der, shdur_der
- double precision, dimension(:,:), allocatable :: hpxir_store,hpetar_store,hpgammar_store
- integer :: nadj_hprec_local
-
-! seismograms
- integer it_begin,it_end,nit_written
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms
- integer :: seismo_offset, seismo_current
-
-! non-dimensionalized rotation rate of the Earth times two
- real(kind=CUSTOM_REAL) two_omega_earth
-
-! for the Euler scheme for rotation
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
- A_array_rotation,B_array_rotation
-
-! number of faces between chunks
- integer 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_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_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_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_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(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
-! Lagrange interpolators at receivers
- 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
-
- 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
-
- integer ichunk,iproc_xi,iproc_eta
-
-!ADJOINT
- real(kind=CUSTOM_REAL) b_two_omega_earth
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
- b_A_array_rotation,b_B_array_rotation
-
- double precision :: time_start
-
-! 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, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,&
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- ANGULAR_WIDTH_XI_IN_DEGREES
-
- logical ONE_CRUST,TOPOGRAPHY,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
-
- character(len=150) OUTPUT_FILES,LOCAL_PATH
-
-! logical COMPUTE_AND_STORE_STRAIN
-
-! for SAC headers for seismograms
- integer yr_SAC,jda_SAC,ho_SAC,mi_SAC
- real mb_SAC
- double precision t_cmt_SAC,t_shift_SAC,elat_SAC,elon_SAC,depth_SAC, &
- cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,sec_SAC
- character(len=20) event_name_SAC
-
-! this for all the regions
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
-
- character(len=150) prname
-
-! lookup table every km for gravity
- real(kind=CUSTOM_REAL) minus_g_cmb,minus_g_icb
- double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table, &
- minus_deriv_gravity_table,density_table,d_ln_density_dr_table,minus_rho_g_over_kappa_fluid
-
-! dummy array that does not need to be actually read
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,1) :: dummy_array
-
-! computed in read_compute_parameters
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-! Boundary Mesh and Kernels
- integer k_top,k_bot,iregion_code
- integer, dimension(NSPEC2D_MOHO) :: ibelm_moho_top,ibelm_moho_bot
- integer, dimension(NSPEC2D_400) :: ibelm_400_top,ibelm_400_bot
- integer, dimension(NSPEC2D_670) :: ibelm_670_top,ibelm_670_bot
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO) :: normal_moho
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_400) :: normal_400
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_670) :: normal_670
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO) :: moho_kl, moho_kl_top, moho_kl_bot
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_400) :: d400_kl, d400_kl_top, d400_kl_bot
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_670) :: d670_kl, d670_kl_top, d670_kl_bot
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_CMB) :: cmb_kl, cmb_kl_top, cmb_kl_bot
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_ICB) :: icb_kl, icb_kl_top, icb_kl_bot
- logical :: fluid_solid_boundary
-
- integer :: i,ier
-
- integer :: imodulo_NGLOB_CRUST_MANTLE
-
-! NOISE_TOMOGRAPHY
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: noise_sourcearray
- integer :: irec_master_noise
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
- normal_x_noise,normal_y_noise,normal_z_noise, mask_noise
-
-! ************** PROGRAM STARTS HERE **************
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-! trivia about the programming style adopted here:
-!
-! note 1: for performance reasons, we try to use as much from the stack memory as possible.
-! This is done to avoid memory fragmentation and also to optimize performance.
-! Stack memory is a place in computer memory where all the variables that are declared
-! and initialized **before** runtime are stored. Our static array allocation will use that one.
-! All variables declared within our main routine also will be stored on the stack.
-!
-! the heap is the section of computer memory where all the variables created or initialized
-! **at** runtime are stored. it is used for dynamic memory allocation.
-!
-! stack is much faster than the heap.
-!
-! when calling a function, additional storage will be allocated for the variables in that function.
-! that storage will be allocated in the heap memory segment.
-!
-! most routine calls here will have rather long argument lists, probably because of this performance criteria.
-! using modules/common data blocks together with dynamic allocation will put data into heap memory,
-! thus it has longer latency to access variables than stack memory variables.
-!
-! however, declaring the static arrays needed in compute_forces_crust_mantle_Dev()
-! like e.g. sum_terms, tempx1,...B1_m1_m2_5points,... in this main routine and
-! passing them along as arguments to the routine makes the code slower.
-! it seems that this stack/heap criterion is more complicated.
-!
-! another reason why modules are avoided is to make the code thread safe.
-! having different threads access the same data structure and modifying it at the same time
-! would lead to problems. passing arguments is a way to avoid such complications.
-!
-! note 2: Most of the computation time is spent
-! inside the time loop (mainly in the compute_forces_crust_mantle_Dev() routine).
-! Any code performance tuning will be most effective in there.
-!
-! note 3: Fortran is a code language that uses column-first ordering for arrays,
-! e.g., it stores a(i,j) in this order: a(1,1),a(2,1),a(3,1),...,a(1,2),a(2,2),a(3,2),..
-! it is therefore more efficient to have the inner-loop over i, and the outer loop over j
-!
-! note 4: Deville et al. (2002) routines significantly reduce the total number of memory accesses
-! required to perform matrix-matrix products at the spectral element level.
-! For most compilers and hardware, will result in a significant speedup (> 30% or more, sometimes twice faster).
-!
-! note 5: a common technique to help compilers enhance pipelining is loop unrolling. We do this here in a simple
-! and straigthforward way, so don't be confused about the do-loop writing.
-!
-! note 6: whenever adding some new code, please make sure to use
-! spaces rather than tabs. Tabulators are in principle not allowed in Fortran95.
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
- ! initialize the MPI communicator and start the NPROCTOT MPI processes.
- call MPI_INIT(ier)
-
- ! initializes simulation parameters
- call initialize_simulation(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,NEX_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,SIMULATION_TYPE, &
- DT,ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670,R771,&
- RTOPDDOUBLEPRIME,RCMB,RICB, &
- RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- HDUR_MOVIE,MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST, &
- MOVIE_NORTH,MOVIE_SOUTH,MOVIE_SURFACE,MOVIE_VOLUME, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
- LOCAL_PATH,OUTPUT_FILES, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top, &
- this_region_has_a_doubling,rmins,rmaxs, &
- TOPOGRAPHY,HONOR_1D_SPHERICAL_MOHO,ONE_CRUST, &
- nspl,rspl,espl,espl2,ibathy_topo, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- xigll,yigll,zigll,wxgll,wygll,wzgll,wgll_cube, &
- hprime_xx,hprime_yy,hprime_zz,hprime_xxT, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- rec_filename,STATIONS,nrec,NOISE_TOMOGRAPHY)
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-! starts reading the databases
- call read_mesh_databases(myrank,rho_vp_crust_mantle,rho_vs_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, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- nspec_iso,nspec_tiso,nspec_ani, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle,is_on_a_slice_edge_crust_mantle,rmass_crust_mantle,rmass_ocean_load, &
- vp_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, &
- rhostore_outer_core,kappavstore_outer_core, &
- ibool_outer_core,idoubling_outer_core,is_on_a_slice_edge_outer_core,rmass_outer_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
- c11store_inner_core,c12store_inner_core,c13store_inner_core, &
- c33store_inner_core,c44store_inner_core, &
- ibool_inner_core,idoubling_inner_core,is_on_a_slice_edge_inner_core,rmass_inner_core, &
- ABSORBING_CONDITIONS,LOCAL_PATH)
-
- ! read 2-D addressing for summation between slices with MPI
- call read_mesh_databases_addressing(myrank, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, &
- iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,npoin2D_faces_crust_mantle, &
- iboolcorner_crust_mantle, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core, &
- iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_xi_outer_core,npoin2D_eta_outer_core,&
- iboolfaces_outer_core,npoin2D_faces_outer_core, &
- iboolcorner_outer_core, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core, &
- iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,npoin2D_faces_inner_core, &
- iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- LOCAL_PATH,OUTPUT_FILES, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XY,NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
- ichunk,iproc_xi,iproc_eta)
-
- ! to couple mantle with outer core
- call read_mesh_databases_coupling(myrank, &
- 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, &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle,normal_ymin_crust_mantle, &
- normal_ymax_crust_mantle,normal_bottom_crust_mantle,normal_top_crust_mantle, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle,jacobian2D_ymin_crust_mantle, &
- jacobian2D_ymax_crust_mantle,jacobian2D_bottom_crust_mantle,jacobian2D_top_crust_mantle, &
- 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, &
- normal_xmin_outer_core,normal_xmax_outer_core,normal_ymin_outer_core, &
- normal_ymax_outer_core,normal_bottom_outer_core,normal_top_outer_core, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core,jacobian2D_ymin_outer_core, &
- jacobian2D_ymax_outer_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
- 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, &
- ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
- ibelm_670_top,ibelm_670_bot,normal_moho,normal_400,normal_670, &
- k_top,k_bot,moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl, &
- LOCAL_PATH,SIMULATION_TYPE)
-
-! 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_CM_IC = max(maxval(npoin2D_xi_crust_mantle(:) + npoin2D_xi_inner_core(:)), &
- maxval(npoin2D_eta_crust_mantle(:) + npoin2D_eta_inner_core(:)))
-
- allocate(buffer_send_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED))
- allocate(buffer_received_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED))
-
- allocate(b_buffer_send_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED))
- allocate(b_buffer_received_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED))
-
- call fix_non_blocking_slices(is_on_a_slice_edge_crust_mantle,iboolright_xi_crust_mantle, &
- iboolleft_xi_crust_mantle,iboolright_eta_crust_mantle,iboolleft_eta_crust_mantle, &
- npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle,ibool_crust_mantle, &
- mask_ibool,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM)
-
- call fix_non_blocking_slices(is_on_a_slice_edge_outer_core,iboolright_xi_outer_core, &
- iboolleft_xi_outer_core,iboolright_eta_outer_core,iboolleft_eta_outer_core, &
- npoin2D_xi_outer_core,npoin2D_eta_outer_core,ibool_outer_core, &
- mask_ibool,NSPEC_OUTER_CORE,NGLOB_OUTER_CORE,NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC)
-
- call fix_non_blocking_slices(is_on_a_slice_edge_inner_core,iboolright_xi_inner_core, &
- iboolleft_xi_inner_core,iboolright_eta_inner_core,iboolleft_eta_inner_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core,ibool_inner_core, &
- mask_ibool,NSPEC_INNER_CORE,NGLOB_INNER_CORE,NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC)
-
- ! absorbing boundaries
- if(ABSORBING_CONDITIONS) then
- ! crust_mantle
- if (nspec2D_xmin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- nabs_xmin_cm = nspec2D_xmin_crust_mantle
- else
- nabs_xmin_cm = 1
- endif
- allocate(absorb_xmin_crust_mantle5(NDIM,NGLLY,NGLLZ,nabs_xmin_cm,8))
-
- if (nspec2D_xmax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- nabs_xmax_cm = nspec2D_xmax_crust_mantle
- else
- nabs_xmax_cm = 1
- endif
- allocate(absorb_xmax_crust_mantle5(NDIM,NGLLY,NGLLZ,nabs_xmax_cm,8))
-
- if (nspec2D_ymin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- nabs_ymin_cm = nspec2D_ymin_crust_mantle
- else
- nabs_ymin_cm = 1
- endif
- allocate(absorb_ymin_crust_mantle5(NDIM,NGLLX,NGLLZ,nabs_ymin_cm,8))
-
- if (nspec2D_ymax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- nabs_ymax_cm = nspec2D_ymax_crust_mantle
- else
- nabs_ymax_cm = 1
- endif
- allocate(absorb_ymax_crust_mantle5(NDIM,NGLLX,NGLLZ,nabs_ymax_cm,8))
-
- ! outer_core
- if (nspec2D_xmin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- nabs_xmin_oc = nspec2D_xmin_outer_core
- else
- nabs_xmin_oc = 1
- endif
- allocate(absorb_xmin_outer_core(NGLLY,NGLLZ,nabs_xmin_oc))
-
- if (nspec2D_xmax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- nabs_xmax_oc = nspec2D_xmax_outer_core
- else
- nabs_xmax_oc = 1
- endif
- allocate(absorb_xmax_outer_core(NGLLY,NGLLZ,nabs_xmax_oc))
-
- if (nspec2D_ymin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- nabs_ymin_oc = nspec2D_ymin_outer_core
- else
- nabs_ymin_oc = 1
- endif
- allocate(absorb_ymin_outer_core(NGLLX,NGLLZ,nabs_ymin_oc))
-
- if (nspec2D_ymax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- nabs_ymax_oc = nspec2D_ymax_outer_core
- else
- nabs_ymax_oc = 1
- endif
- allocate(absorb_ymax_outer_core(NGLLX,NGLLZ,nabs_ymax_oc))
-
- if (NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 .and. &
- (SIMULATION_TYPE == 3 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- nabs_zmin_oc = NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
- else
- nabs_zmin_oc = 1
- endif
- allocate(absorb_zmin_outer_core(NGLLX,NGLLY,nabs_zmin_oc))
-
- ! read arrays for Stacey conditions
- call read_mesh_databases_stacey(myrank, &
- nimin_crust_mantle,nimax_crust_mantle,njmin_crust_mantle, &
- njmax_crust_mantle,nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nimin_outer_core,nimax_outer_core,njmin_outer_core, &
- njmax_outer_core,nkmin_xi_outer_core,nkmin_eta_outer_core, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- reclen_zmin,NSPEC2D_BOTTOM, &
- SIMULATION_TYPE,SAVE_FORWARD,LOCAL_PATH,NSTEP)
-
- endif
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-! source and receivers
-
- ! 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(tshift_cmt(NSOURCES))
- allocate(hdur(NSOURCES))
- allocate(hdur_gaussian(NSOURCES))
- allocate(theta_source(NSOURCES))
- allocate(phi_source(NSOURCES))
- allocate(nu_source(NDIM,NDIM,NSOURCES))
-
- ! 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(stbur(nrec))
- allocate(nu(NDIM,NDIM,nrec))
-
- ! locates sources and receivers
- call setup_sources_receivers(NSOURCES,myrank,ibool_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xigll,yigll,zigll,TOPOGRAPHY, &
- sec,tshift_cmt,theta_source,phi_source, &
- NSTEP,DT,hdur,hdur_gaussian,t0,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, &
- rec_filename,nrec,islice_selected_rec,ispec_selected_rec, &
- xi_receiver,eta_receiver,gamma_receiver,station_name,network_name, &
- stlat,stlon,stele,stbur,nu, &
- nrec_local,nadj_rec_local,nrec_simulation, &
- SIMULATION_TYPE,RECEIVERS_CAN_BE_BURIED,MOVIE_SURFACE,MOVIE_VOLUME, &
- HDUR_MOVIE,OUTPUT_FILES,LOCAL_PATH)
-
- ! allocates source arrays
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- allocate(sourcearrays(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES))
-
- ! stores source arrays
- call setup_sources_receivers_srcarr(NSOURCES,myrank, &
- ispec_selected_source,islice_selected_source, &
- xi_source,eta_source,gamma_source, &
- Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- 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,sourcearrays)
- endif
-
-
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- NSTEP_SUB_ADJ = ceiling( dble(NSTEP)/dble(NTSTEP_BETWEEN_READ_ADJSRC) )
- allocate(iadj_vec(NSTEP))
- ! initializes iadj_vec
- do it=1,NSTEP
- iadj_vec(it) = NSTEP-it+1 ! default is for reversing entire record
- enddo
-
- if(nadj_rec_local > 0) then
- ! allocate adjoint source arrays
- allocate(adj_sourcearrays(NDIM,NGLLX,NGLLY,NGLLZ,nadj_rec_local,NTSTEP_BETWEEN_READ_ADJSRC))
- adj_sourcearrays = 0._CUSTOM_REAL
-
- ! allocate indexing arrays
- allocate(iadjsrc(NSTEP_SUB_ADJ,2))
- allocate(iadjsrc_len(NSTEP_SUB_ADJ))
- ! initializes iadjsrc, iadjsrc_len and iadj_vec
- call setup_sources_receivers_adjindx(NSTEP,NSTEP_SUB_ADJ, &
- NTSTEP_BETWEEN_READ_ADJSRC, &
- iadjsrc,iadjsrc_len,iadj_vec)
- endif
- endif
-
- ! allocates receiver interpolators
- 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))
- ! define and store Lagrange interpolators at all the receivers
- if (SIMULATION_TYPE == 2) then
- nadj_hprec_local = nrec_local
- else
- nadj_hprec_local = 1
- endif
- allocate(hpxir_store(nadj_hprec_local,NGLLX))
- allocate(hpetar_store(nadj_hprec_local,NGLLY))
- allocate(hpgammar_store(nadj_hprec_local,NGLLZ))
-
- ! stores interpolators for receiver positions
- call setup_sources_receivers_intp(NSOURCES,myrank, &
- islice_selected_source, &
- xi_source,eta_source,gamma_source, &
- xigll,yigll,zigll, &
- SIMULATION_TYPE,nrec,nrec_local, &
- islice_selected_rec,number_receiver_global, &
- xi_receiver,eta_receiver,gamma_receiver, &
- hxir_store,hetar_store,hgammar_store, &
- nadj_hprec_local,hpxir_store,hpetar_store,hpgammar_store)
-
- ! allocate seismogram array
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- allocate(seismograms(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
- if(ier /= 0) stop 'error while allocating seismograms'
- else
- allocate(seismograms(NDIM*NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
- if(ier /= 0) stop 'error while allocating seismograms'
- ! allocate Frechet derivatives array
- allocate(moment_der(NDIM,NDIM,nrec_local),sloc_der(NDIM,nrec_local),stshift_der(nrec_local),shdur_der(nrec_local))
- moment_der = 0._CUSTOM_REAL
- sloc_der = 0._CUSTOM_REAL
- stshift_der = 0._CUSTOM_REAL
- shdur_der = 0._CUSTOM_REAL
-
- endif
- ! initialize seismograms
- seismograms(:,:,:) = 0._CUSTOM_REAL
- nit_written = 0
- endif
-
- ! get information about event name and location for SAC seismograms
-
- ! The following line is added for get_event_info subroutine.
- ! Because the way NSOURCES_SAC was declared has been changed.
- ! The rest of the changes in this program is just the updates of the subroutines that
- ! I did changes, e.g., adding/removing parameters. by Ebru Bozdag
- call get_event_info_parallel(myrank,yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,&
- event_name_SAC,t_cmt_SAC,t_shift_SAC, &
- elat_SAC,elon_SAC,depth_SAC,mb_SAC,cmt_lat_SAC,&
- cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,NSOURCES)
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
- ! user output
- if(myrank == 0) then
-
- write(IMAIN,*)
- write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
- write(IMAIN,*)
-
- write(IMAIN,*)
- if(OCEANS_VAL) then
- write(IMAIN,*) 'incorporating the oceans using equivalent load'
- else
- write(IMAIN,*) 'no oceans'
- endif
-
- 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(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(ATTENUATION_VAL) then
- write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
-
- if(ATTENUATION_3D_VAL) write(IMAIN,*) 'using 3D attenuation'
-
- if(USE_ATTENUATION_MIMIC ) write(IMAIN,*) 'mimicking effects on velocity only'
- else
- write(IMAIN,*) 'no attenuation'
- endif
-
- write(IMAIN,*)
- write(IMAIN,*)
- write(IMAIN,*)
-
- endif
-
- ! the mass matrix needs to be assembled with MPI here once and for all
- call prepare_timerun_rmass(myrank,rmass_ocean_load,rmass_crust_mantle, &
- rmass_outer_core,rmass_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_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, &
- 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, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,npoin2D_max_all_CM_IC)
-
- ! mass matrix including central cube
- 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_VAL,NPROC_ETA_VAL,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(b_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(b_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))
-
- ! handles the communications with the central cube if it was included in the mesh
- call prepare_timerun_centralcube(myrank,rmass_inner_core, &
- iproc_xi,iproc_eta,ichunk, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM, &
- 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)
-
- call fix_non_blocking_central_cube(is_on_a_slice_edge_inner_core, &
- ibool_inner_core,NSPEC_INNER_CORE,NGLOB_INNER_CORE,nb_msgs_theor_in_cube,ibelm_bottom_inner_core, &
- idoubling_inner_core,npoin2D_cube_from_slices,ibool_central_cube, &
- NSPEC2D_BOTTOM(IREGION_INNER_CORE),ichunk)
-
- else
-
- ! allocate fictitious buffers for cube and slices with a dummy size
- ! just to be able to use them as arguments in subroutine calls
- allocate(sender_from_slices_to_cube(1))
- allocate(buffer_all_cube_from_slices(1,1,1))
- allocate(b_buffer_all_cube_from_slices(1,1,1))
- allocate(buffer_slices(1,1))
- allocate(b_buffer_slices(1,1))
- allocate(buffer_slices2(1,1))
- allocate(ibool_central_cube(1,1))
-
- endif
-
- ! check that all the mass matrices are positive
- if(OCEANS_VAL) then
- if(minval(rmass_ocean_load) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the oceans')
- endif
- if(minval(rmass_crust_mantle) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the crust_mantle')
- if(minval(rmass_inner_core) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the inner core')
- if(minval(rmass_outer_core) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the outer core')
-
- ! for efficiency, invert final mass matrix once and for all on each slice
- if(OCEANS_VAL) 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 i = 1,NGLOB_CRUST_MANTLE
- call xyz_2_rthetaphi(xstore_crust_mantle(i), &
- ystore_crust_mantle(i), &
- zstore_crust_mantle(i),rval,thetaval,phival)
- xstore_crust_mantle(i) = rval
- ystore_crust_mantle(i) = thetaval
- zstore_crust_mantle(i) = phival
- enddo
-
- ! convert in the outer core
- do i = 1,NGLOB_OUTER_CORE
- call xyz_2_rthetaphi(xstore_outer_core(i), &
- ystore_outer_core(i), &
- zstore_outer_core(i),rval,thetaval,phival)
- xstore_outer_core(i) = rval
- ystore_outer_core(i) = thetaval
- zstore_outer_core(i) = phival
- enddo
-
- ! convert in the inner core
- do i = 1,NGLOB_INNER_CORE
- call xyz_2_rthetaphi(xstore_inner_core(i), &
- ystore_inner_core(i), &
- zstore_inner_core(i),rval,thetaval,phival)
- xstore_inner_core(i) = rval
- ystore_inner_core(i) = thetaval
- zstore_inner_core(i) = phival
- enddo
-
- ! allocate files to save movies
- if(MOVIE_SURFACE .or. NOISE_TOMOGRAPHY /=0) then ! for noise tomography, store_val_x/y/z/ux/uy/uz needed for 'surface movie'
- if(MOVIE_COARSE .and. NOISE_TOMOGRAPHY ==0) then ! only output corners !for noise tomography, must NOT be coarse
- nmovie_points = 2 * 2 * NSPEC2D_TOP(IREGION_CRUST_MANTLE)
- if(NGLLX /= NGLLY) &
- call exit_MPI(myrank,'MOVIE_COARSE together with MOVIE_SURFACE requires NGLLX=NGLLY')
- NIT = NGLLX - 1
- else
- nmovie_points = NGLLX * NGLLY * NSPEC2D_TOP(IREGION_CRUST_MANTLE)
- NIT = 1
- endif
- allocate(store_val_x(nmovie_points))
- allocate(store_val_y(nmovie_points))
- allocate(store_val_z(nmovie_points))
- allocate(store_val_ux(nmovie_points))
- allocate(store_val_uy(nmovie_points))
- allocate(store_val_uz(nmovie_points))
- if (MOVIE_SURFACE) then ! those arrays are not neccessary for noise tomography, so only allocate them in MOVIE_SURFACE case
- allocate(store_val_x_all(nmovie_points,0:NPROCTOT_VAL-1))
- allocate(store_val_y_all(nmovie_points,0:NPROCTOT_VAL-1))
- allocate(store_val_z_all(nmovie_points,0:NPROCTOT_VAL-1))
- allocate(store_val_ux_all(nmovie_points,0:NPROCTOT_VAL-1))
- allocate(store_val_uy_all(nmovie_points,0:NPROCTOT_VAL-1))
- allocate(store_val_uz_all(nmovie_points,0:NPROCTOT_VAL-1))
- endif
- endif
-
-
- ! output point and element information for 3D movies
- if(MOVIE_VOLUME) then
- ! the following has to be true for the the array dimensions of eps to match with those of xstore etc..
- ! note that epsilondev and eps_trace_over_3 don't have the same dimensions.. could cause trouble
- if (NSPEC_CRUST_MANTLE_STR_OR_ATT /= NSPEC_CRUST_MANTLE) &
- stop 'NSPEC_CRUST_MANTLE_STRAINS_ATT /= NSPEC_CRUST_MANTLE'
- if (NSPEC_CRUST_MANTLE_STRAIN_ONLY /= NSPEC_CRUST_MANTLE) &
- stop 'NSPEC_CRUST_MANTLE_STRAIN_ONLY /= NSPEC_CRUST_MANTLE'
-
- write(prname,'(a,i6.6,a)') trim(LOCAL_PATH)//'/'//'proc',myrank,'_'
- call count_points_movie_volume(prname,ibool_crust_mantle, xstore_crust_mantle,ystore_crust_mantle, &
- zstore_crust_mantle,MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- MOVIE_COARSE,npoints_3dmovie,nspecel_3dmovie,num_ibool_3dmovie,mask_ibool,mask_3dmovie)
-
-
- allocate(nu_3dmovie(3,3,npoints_3dmovie))
-
- call write_movie_volume_mesh(npoints_3dmovie,prname,ibool_crust_mantle,xstore_crust_mantle, &
- ystore_crust_mantle,zstore_crust_mantle, muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,mask_ibool,num_ibool_3dmovie,nu_3dmovie,MOVIE_COARSE)
-
- if(myrank == 0) then
- write(IMAIN,*) 'Writing to movie3D files on local disk'
- write(IMAIN,*) 'depth(T,B):',MOVIE_TOP,MOVIE_BOTTOM
- write(IMAIN,*) 'lon(W,E) :',MOVIE_WEST,MOVIE_EAST
- write(IMAIN,*) 'lat(S,N) :',MOVIE_SOUTH,MOVIE_NORTH
- write(IMAIN,*) 'Starting at time step:',MOVIE_START, 'ending at:',MOVIE_STOP,'every: ',NTSTEP_BETWEEN_FRAMES
- endif
-
- endif ! MOVIE_VOLUME
-
- ! sets up time increments and rotation constants
- call prepare_timerun_constants(myrank,NSTEP, &
- DT,t0,scale_t,scale_t_inv,scale_displ,scale_veloc, &
- deltat,deltatover2,deltatsqover2, &
- b_deltat,b_deltatover2,b_deltatsqover2, &
- two_omega_earth,A_array_rotation,B_array_rotation, &
- b_two_omega_earth, SIMULATION_TYPE)
-
- ! precomputes gravity factors
- call prepare_timerun_gravity(myrank, &
- minus_g_cmb,minus_g_icb, &
- minus_gravity_table,minus_deriv_gravity_table, &
- density_table,d_ln_density_dr_table,minus_rho_g_over_kappa_fluid, &
- ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- ! precomputes attenuation factors
- if(ATTENUATION_VAL) then
- call prepare_timerun_attenuation(myrank, &
- factor_scale_crust_mantle,one_minus_sum_beta_crust_mantle,factor_common_crust_mantle, &
- factor_scale_inner_core,one_minus_sum_beta_inner_core,factor_common_inner_core, &
- 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, &
- muvstore_crust_mantle,muhstore_crust_mantle,idoubling_crust_mantle, &
- muvstore_inner_core, &
- SIMULATION_TYPE,MOVIE_VOLUME,muvstore_crust_mantle_3dmovie, &
- c11store_inner_core,c12store_inner_core,c13store_inner_core, &
- c33store_inner_core,c44store_inner_core, &
- alphaval,betaval,gammaval,b_alphaval,b_betaval,b_gammaval, &
- deltat,b_deltat,LOCAL_PATH)
- endif
-
- if(myrank == 0) then
-
- write(IMAIN,*) 'for overlapping of communications with calculations:'
- write(IMAIN,*)
-
- percentage_edge = 100.*count(is_on_a_slice_edge_crust_mantle(:))/real(NSPEC_CRUST_MANTLE)
- write(IMAIN,*) 'percentage of edge elements in crust/mantle ',percentage_edge,'%'
- write(IMAIN,*) 'percentage of volume elements in crust/mantle ',100. - percentage_edge,'%'
- write(IMAIN,*)
-
- percentage_edge = 100.*count(is_on_a_slice_edge_outer_core(:))/real(NSPEC_OUTER_CORE)
- write(IMAIN,*) 'percentage of edge elements in outer core ',percentage_edge,'%'
- write(IMAIN,*) 'percentage of volume elements in outer core ',100. - percentage_edge,'%'
- write(IMAIN,*)
-
- percentage_edge = 100.*count(is_on_a_slice_edge_inner_core(:))/real(NSPEC_INNER_CORE)
- write(IMAIN,*) 'percentage of edge elements in inner core ',percentage_edge,'%'
- write(IMAIN,*) 'percentage of volume elements in inner core ',100. - percentage_edge,'%'
- write(IMAIN,*)
-
- endif
-
- if(.not. USE_NONBLOCKING_COMMS) then
- is_on_a_slice_edge_crust_mantle(:) = .true.
- is_on_a_slice_edge_outer_core(:) = .true.
- is_on_a_slice_edge_inner_core(:) = .true.
- 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
-
- if (SIMULATION_TYPE == 3) then
- rho_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- beta_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- alpha_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- if (NOISE_TOMOGRAPHY == 3) Sigma_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
-
- ! approximate hessian
- if( APPROXIMATE_HESS_KL ) then
- allocate( hess_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT))
- hess_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- endif
-
- ! For anisotropic kernels (in crust_mantle only)
- cijkl_kl_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
-
- rho_kl_outer_core(:,:,:,:) = 0._CUSTOM_REAL
- alpha_kl_outer_core(:,:,:,:) = 0._CUSTOM_REAL
- beta_kl_outer_core(:,:,:,:) = 0._CUSTOM_REAL
-
- rho_kl_inner_core(:,:,:,:) = 0._CUSTOM_REAL
- beta_kl_inner_core(:,:,:,:) = 0._CUSTOM_REAL
- alpha_kl_inner_core(:,:,:,:) = 0._CUSTOM_REAL
-
- div_displ_outer_core(:,:,:,:) = 0._CUSTOM_REAL
- b_div_displ_outer_core(:,:,:,:) = 0._CUSTOM_REAL
-
- ! deviatoric kernel check
- if( deviatoric_outercore) then
- nspec_beta_kl_outer_core = NSPEC_OUTER_CORE_ADJOINT
- else
- nspec_beta_kl_outer_core = 1
- endif
- allocate(beta_kl_outer_core(NGLLX,NGLLY,NGLLZ,nspec_beta_kl_outer_core))
- beta_kl_outer_core = 0._CUSTOM_REAL
- endif
-
- ! initialize to be on the save side for adjoint runs SIMULATION_TYPE==2
- eps_trace_over_3_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
- eps_trace_over_3_inner_core(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
- if(FIX_UNDERFLOW_PROBLEM) then
- eps_trace_over_3_crust_mantle(:,:,:,:) = VERYSMALLVAL
- epsilondev_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
- eps_trace_over_3_inner_core(:,:,:,:) = VERYSMALLVAL
- epsilondev_inner_core(:,:,:,:,:) = VERYSMALLVAL
- endif
-
- if (COMPUTE_AND_STORE_STRAIN) then
- if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3)) then
- Iepsilondev_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
- Ieps_trace_over_3_crust_mantle(:,:,:,:)=0._CUSTOM_REAL
- endif
- endif
-
- ! clear memory variables if attenuation
- if(ATTENUATION_VAL) then
- 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
-
- ! reads files back from local disk or MT tape system if restart file
- ! note: for SIMULATION_TYPE 3 simulations, the stored wavefields
- ! will be read in the time loop after the Newmark time scheme update.
- ! this makes indexing and timing easier to match with adjoint wavefields indexing.
- call read_forward_arrays_startrun(myrank,NSTEP, &
- SIMULATION_TYPE,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
- it_begin,it_end, &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
- displ_inner_core,veloc_inner_core,accel_inner_core, &
- displ_outer_core,veloc_outer_core,accel_outer_core, &
- R_memory_crust_mantle,R_memory_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
- A_array_rotation,B_array_rotation, &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
- b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
- b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
-
-!<YANGL
- ! NOISE TOMOGRAPHY
- if ( NOISE_TOMOGRAPHY /= 0 ) then
- allocate(noise_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NSTEP))
- allocate(normal_x_noise(nmovie_points))
- allocate(normal_y_noise(nmovie_points))
- allocate(normal_z_noise(nmovie_points))
- allocate(mask_noise(nmovie_points))
- noise_sourcearray(:,:,:,:,:) = 0._CUSTOM_REAL
- normal_x_noise(:) = 0._CUSTOM_REAL
- normal_y_noise(:) = 0._CUSTOM_REAL
- normal_z_noise(:) = 0._CUSTOM_REAL
- mask_noise(:) = 0._CUSTOM_REAL
-
- call read_parameters_noise(myrank,nrec,NSTEP,nmovie_points, &
- islice_selected_rec,xi_receiver,eta_receiver,gamma_receiver,nu, &
- noise_sourcearray,xigll,yigll,zigll,NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- NIT, ibool_crust_mantle, ibelm_top_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- irec_master_noise,normal_x_noise,normal_y_noise,normal_z_noise,mask_noise)
-
- if (myrank == 0) &
- call check_parameters_noise(myrank,NOISE_TOMOGRAPHY,SIMULATION_TYPE,SAVE_FORWARD, &
- NUMBER_OF_RUNS, NUMBER_OF_THIS_RUN,ROTATE_SEISMOGRAMS_RT, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE, USE_BINARY_FOR_LARGE_FILE, &
- MOVIE_COARSE)
- endif
-!>YANGL
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
-!
-! s t a r t t i m e i t e r a t i o n s
-!
-
-! synchronize all processes to make sure everybody is ready to start time loop
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
- if(myrank == 0) write(IMAIN,*) 'All processes are synchronized before time loop'
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'Starting time iteration loop...'
- write(IMAIN,*)
- endif
-
-! create an empty file to monitor the start of the simulation
- if(myrank == 0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/starttimeloop.txt',status='unknown',action='write')
- write(IOUT,*) 'hello, starting time loop'
- close(IOUT)
- endif
-
-! initialize variables for writing seismograms
- seismo_offset = it_begin-1
- seismo_current = 0
-
- imodulo_NGLOB_CRUST_MANTLE = mod(NGLOB_CRUST_MANTLE,3)
-
-! get MPI starting time
- time_start = MPI_WTIME()
-
-! *********************************************************
-! ************* MAIN LOOP OVER THE TIME STEPS *************
-! *********************************************************
-
- do it = it_begin,it_end
-
- ! update position in seismograms
- seismo_current = seismo_current + 1
-
-! way 1:
-! ! mantle
-! do i=1,NGLOB_CRUST_MANTLE
-! displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
-! + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
-! veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
-! + deltatover2*accel_crust_mantle(:,i)
-! 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
-
-! way 2:
-! One common technique in computational science to help enhance pipelining is loop unrolling
-!
-! we're accessing NDIM=3 components at each line,
-! that is, for an iteration, the register must contain
-! NDIM * displ_ + NDIM * veloc_ + NDIM * accel + deltat + deltatsq..
-! in most cases a real (CUSTOM_REAL) value will have 4 bytes,
-! assuming a default cache size of about 128 bytes, we unroll here in steps of 3, thus 29 reals or 118 bytes,
-! rather than with steps of 4
- if(imodulo_NGLOB_CRUST_MANTLE >= 1) then
- do i = 1,imodulo_NGLOB_CRUST_MANTLE
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
-
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
-
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- endif
-
- do i = mod(NGLOB_CRUST_MANTLE,3)+1,NGLOB_CRUST_MANTLE, 3 ! in steps of 3
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
- displ_crust_mantle(:,i+1) = displ_crust_mantle(:,i+1) &
- + deltat*veloc_crust_mantle(:,i+1) + deltatsqover2*accel_crust_mantle(:,i+1)
- displ_crust_mantle(:,i+2) = displ_crust_mantle(:,i+2) &
- + deltat*veloc_crust_mantle(:,i+2) + deltatsqover2*accel_crust_mantle(:,i+2)
-
-
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i+1) = veloc_crust_mantle(:,i+1) &
- + deltatover2*accel_crust_mantle(:,i+1)
- veloc_crust_mantle(:,i+2) = veloc_crust_mantle(:,i+2) &
- + deltatover2*accel_crust_mantle(:,i+2)
-
- ! set acceleration to zero
- ! note: we do initialize acceleration in this loop since it is read already into the cache,
- ! otherwise it would have to be read in again for this explicitly,
- ! which would make this step more expensive
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- accel_crust_mantle(:,i+1) = 0._CUSTOM_REAL
- accel_crust_mantle(:,i+2) = 0._CUSTOM_REAL
- enddo
-
-
- ! outer core
- do i = 1,mod(NGLOB_OUTER_CORE,4)
- displ_outer_core(i) = displ_outer_core(i) &
- + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
-
- veloc_outer_core(i) = veloc_outer_core(i) &
- + deltatover2*accel_outer_core(i)
-
- accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- do i = mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE, 4 ! in steps of 4
- displ_outer_core(i) = displ_outer_core(i) &
- + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
- displ_outer_core(i+1) = displ_outer_core(i+1) &
- + deltat*veloc_outer_core(i+1) + deltatsqover2*accel_outer_core(i+1)
- displ_outer_core(i+2) = displ_outer_core(i+2) &
- + deltat*veloc_outer_core(i+2) + deltatsqover2*accel_outer_core(i+2)
- displ_outer_core(i+3) = displ_outer_core(i+3) &
- + deltat*veloc_outer_core(i+3) + deltatsqover2*accel_outer_core(i+3)
-
- veloc_outer_core(i) = veloc_outer_core(i) &
- + deltatover2*accel_outer_core(i)
- veloc_outer_core(i+1) = veloc_outer_core(i+1) &
- + deltatover2*accel_outer_core(i+1)
- veloc_outer_core(i+2) = veloc_outer_core(i+2) &
- + deltatover2*accel_outer_core(i+2)
- veloc_outer_core(i+3) = veloc_outer_core(i+3) &
- + deltatover2*accel_outer_core(i+3)
-
- accel_outer_core(i) = 0._CUSTOM_REAL
- accel_outer_core(i+1) = 0._CUSTOM_REAL
- accel_outer_core(i+2) = 0._CUSTOM_REAL
- accel_outer_core(i+3) = 0._CUSTOM_REAL
- enddo
-
-
- ! inner core
- do i = 1,mod(NGLOB_INNER_CORE,3)
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
-
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
- do i = mod(NGLOB_INNER_CORE,3)+1,NGLOB_INNER_CORE, 3 ! in steps of 3
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
- displ_inner_core(:,i+1) = displ_inner_core(:,i+1) &
- + deltat*veloc_inner_core(:,i+1) + deltatsqover2*accel_inner_core(:,i+1)
- displ_inner_core(:,i+2) = displ_inner_core(:,i+2) &
- + deltat*veloc_inner_core(:,i+2) + deltatsqover2*accel_inner_core(:,i+2)
-
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
- veloc_inner_core(:,i+1) = veloc_inner_core(:,i+1) &
- + deltatover2*accel_inner_core(:,i+1)
- veloc_inner_core(:,i+2) = veloc_inner_core(:,i+2) &
- + deltatover2*accel_inner_core(:,i+2)
-
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- accel_inner_core(:,i+1) = 0._CUSTOM_REAL
- accel_inner_core(:,i+2) = 0._CUSTOM_REAL
- enddo
-
-
-
- ! backward field
- if (SIMULATION_TYPE == 3) then
-! way 1:
-! do i=1,NGLOB_CRUST_MANTLE
-! b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
-! + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
-! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
-! + b_deltatover2*b_accel_crust_mantle(:,i)
-! enddo
-! do i=1,NGLOB_OUTER_CORE
-! b_displ_outer_core(i) = b_displ_outer_core(i) &
-! + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
-! b_veloc_outer_core(i) = b_veloc_outer_core(i) &
-! + b_deltatover2*b_accel_outer_core(i)
-! enddo
-! do i=1,NGLOB_INNER_CORE
-! b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
-! + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
-! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
-! + b_deltatover2*b_accel_inner_core(:,i)
-! enddo
-
-! way 2:
- if(imodulo_NGLOB_CRUST_MANTLE >= 1) then
- do i=1,imodulo_NGLOB_CRUST_MANTLE
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- endif
-
- do i=mod(NGLOB_CRUST_MANTLE,3)+1,NGLOB_CRUST_MANTLE,3
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_displ_crust_mantle(:,i+1) = b_displ_crust_mantle(:,i+1) &
- + b_deltat*b_veloc_crust_mantle(:,i+1) + b_deltatsqover2*b_accel_crust_mantle(:,i+1)
- b_displ_crust_mantle(:,i+2) = b_displ_crust_mantle(:,i+2) &
- + b_deltat*b_veloc_crust_mantle(:,i+2) + b_deltatsqover2*b_accel_crust_mantle(:,i+2)
-
-
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i+1) = b_veloc_crust_mantle(:,i+1) &
- + b_deltatover2*b_accel_crust_mantle(:,i+1)
- b_veloc_crust_mantle(:,i+2) = b_veloc_crust_mantle(:,i+2) &
- + b_deltatover2*b_accel_crust_mantle(:,i+2)
-
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- b_accel_crust_mantle(:,i+1) = 0._CUSTOM_REAL
- b_accel_crust_mantle(:,i+2) = 0._CUSTOM_REAL
- enddo
-
-
- do i=1,mod(NGLOB_OUTER_CORE,4)
- b_displ_outer_core(i) = b_displ_outer_core(i) &
- + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) &
- + b_deltatover2*b_accel_outer_core(i)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- do i=mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE,4
- b_displ_outer_core(i) = b_displ_outer_core(i) &
- + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
- b_displ_outer_core(i+1) = b_displ_outer_core(i+1) &
- + b_deltat*b_veloc_outer_core(i+1) + b_deltatsqover2*b_accel_outer_core(i+1)
- b_displ_outer_core(i+2) = b_displ_outer_core(i+2) &
- + b_deltat*b_veloc_outer_core(i+2) + b_deltatsqover2*b_accel_outer_core(i+2)
- b_displ_outer_core(i+3) = b_displ_outer_core(i+3) &
- + b_deltat*b_veloc_outer_core(i+3) + b_deltatsqover2*b_accel_outer_core(i+3)
-
- b_veloc_outer_core(i) = b_veloc_outer_core(i) &
- + b_deltatover2*b_accel_outer_core(i)
- b_veloc_outer_core(i+1) = b_veloc_outer_core(i+1) &
- + b_deltatover2*b_accel_outer_core(i+1)
- b_veloc_outer_core(i+2) = b_veloc_outer_core(i+2) &
- + b_deltatover2*b_accel_outer_core(i+2)
- b_veloc_outer_core(i+3) = b_veloc_outer_core(i+3) &
- + b_deltatover2*b_accel_outer_core(i+3)
-
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- b_accel_outer_core(i+1) = 0._CUSTOM_REAL
- b_accel_outer_core(i+2) = 0._CUSTOM_REAL
- b_accel_outer_core(i+3) = 0._CUSTOM_REAL
- enddo
-
-
- do i=1,mod(NGLOB_INNER_CORE,3)
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
- do i=mod(NGLOB_INNER_CORE,3)+1,NGLOB_INNER_CORE,3
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_displ_inner_core(:,i+1) = b_displ_inner_core(:,i+1) &
- + b_deltat*b_veloc_inner_core(:,i+1) + b_deltatsqover2*b_accel_inner_core(:,i+1)
- b_displ_inner_core(:,i+2) = b_displ_inner_core(:,i+2) &
- + b_deltat*b_veloc_inner_core(:,i+2) + b_deltatsqover2*b_accel_inner_core(:,i+2)
-
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i+1) = b_veloc_inner_core(:,i+1) &
- + b_deltatover2*b_accel_inner_core(:,i+1)
- b_veloc_inner_core(:,i+2) = b_veloc_inner_core(:,i+2) &
- + b_deltatover2*b_accel_inner_core(:,i+2)
-
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- b_accel_inner_core(:,i+1) = 0._CUSTOM_REAL
- b_accel_inner_core(:,i+2) = 0._CUSTOM_REAL
- enddo
-
- endif
-
- ! integral of strain for adjoint movie volume
- if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) ) then
- Iepsilondev_crust_mantle(:,:,:,:,:) = Iepsilondev_crust_mantle(:,:,:,:,:) &
- + deltat*epsilondev_crust_mantle(:,:,:,:,:)
- Ieps_trace_over_3_crust_mantle(:,:,:,:) = Ieps_trace_over_3_crust_mantle(:,:,:,:) &
- + deltat*eps_trace_over_3_crust_mantle(:,:,:,:)
- endif
-
- ! daniel: debugging
- !if( maxval(displ_crust_mantle(1,:)**2 + &
- ! displ_crust_mantle(2,:)**2 + displ_crust_mantle(3,:)**2) > 1.e4 ) then
- ! print*,'slice',myrank
- ! print*,' crust_mantle displ:', maxval(displ_crust_mantle(1,:)), &
- ! maxval(displ_crust_mantle(2,:)),maxval(displ_crust_mantle(3,:))
- ! print*,' indxs: ',maxloc( displ_crust_mantle(1,:)),maxloc( displ_crust_mantle(2,:)),maxloc( displ_crust_mantle(3,:))
- ! indx = maxloc( displ_crust_mantle(3,:) )
- ! rval = xstore_crust_mantle(indx(1))
- ! thetaval = ystore_crust_mantle(indx(1))
- ! phival = zstore_crust_mantle(indx(1))
- ! !thetaval = PI/2.0d0-datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dsin(dble(thetaval))))
- ! print*,'r/lat/lon:',rval*R_EARTH_KM,90.0-thetaval*180./PI,phival*180./PI
- ! call rthetaphi_2_xyz(rval,thetaval,phival,xstore_crust_mantle(indx(1)),&
- ! ystore_crust_mantle(indx(1)),zstore_crust_mantle(indx(1)))
- ! print*,'x/y/z:',rval,thetaval,phival
- ! call exit_MPI(myrank,'error stability')
- !endif
-
-
- ! 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) &
- call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
- b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
- myrank)
-
-
- ! ****************************************************
- ! big loop over all spectral elements in the fluid
- ! ****************************************************
-
- ! compute internal forces in the fluid region
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
- else
- time = (dble(it-1)*DT-t0)*scale_t_inv
- endif
-
- iphase = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- if (SIMULATION_TYPE == 3) then
- ! note on backward/reconstructed wavefields:
- ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
- ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
- ! to a time (NSTEP - (it-1) - 1)*DT - t0
- ! for reconstructing the rotational contributions
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
- else
- time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
- endif
-
- b_iphase = 0 ! do not start any non blocking communications at this stage
- b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
- endif
-
- ! Stacey absorbing boundaries
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
- NSTEP,it,ibool_outer_core, &
- veloc_outer_core,accel_outer_core,b_accel_outer_core, &
- vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
- jacobian2D_bottom_outer_core, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
- jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
- ibelm_bottom_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
- ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- nimin_outer_core,nimax_outer_core, &
- njmin_outer_core,njmax_outer_core, &
- nkmin_xi_outer_core,nkmin_eta_outer_core, &
- NSPEC2D_BOTTOM, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_zmin, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- nabs_zmin_oc, &
- nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
- absorb_zmin_outer_core, &
- absorb_xmin_outer_core,absorb_xmax_outer_core, &
- absorb_ymin_outer_core,absorb_ymax_outer_core)
- endif ! Stacey conditions
-
-
- ! ****************************************************
- ! ********** add matching with solid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the fluid
-
- !---
- !--- couple with mantle at the top of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) &
- call compute_coupling_fluid_CMB(displ_crust_mantle,b_displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_OUTER_CORE))
-
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) &
- call compute_coupling_fluid_ICB(displ_inner_core,b_displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
-
-
- ! assemble all the contributions between slices using MPI
-
- ! outer core
- if(USE_NONBLOCKING_COMMS) then
- iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY,NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY,NCHUNKS_VAL,iphase)
- enddo
-
- else ! if(.not. USE_NONBLOCKING_COMMS) then
-
- call assemble_MPI_scalar_block(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_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY,NCHUNKS_VAL)
-
- endif
-
- ! multiply by the inverse of the mass matrix and update velocity
-
-! way 1:
-! 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
-
-! way 2:
- do i=1,mod(NGLOB_OUTER_CORE,4)
- 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
- do i=mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE,4
- accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
- accel_outer_core(i+1) = accel_outer_core(i+1)*rmass_outer_core(i+1)
- accel_outer_core(i+2) = accel_outer_core(i+2)*rmass_outer_core(i+2)
- accel_outer_core(i+3) = accel_outer_core(i+3)*rmass_outer_core(i+3)
-
- veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
- veloc_outer_core(i+1) = veloc_outer_core(i+1) + deltatover2*accel_outer_core(i+1)
- veloc_outer_core(i+2) = veloc_outer_core(i+2) + deltatover2*accel_outer_core(i+2)
- veloc_outer_core(i+3) = veloc_outer_core(i+3) + deltatover2*accel_outer_core(i+3)
- enddo
-
- if (SIMULATION_TYPE == 3) then
-
-! ------------------- new non blocking implementation -------------------
-
- ! outer core
- if(USE_NONBLOCKING_COMMS) then
- b_iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY,NCHUNKS_VAL,b_iphase)
-
- b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- do while (b_iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY,NCHUNKS_VAL,b_iphase)
- enddo
-
- else ! if(.not. USE_NONBLOCKING_COMMS) then
-
- call assemble_MPI_scalar_block(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core, &
- iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY,NCHUNKS_VAL)
-
- endif
-
-! ------------------- new non blocking implementation -------------------
-
-! way 1:
-! do i=1,NGLOB_OUTER_CORE
-! b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
-! b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
-! enddo
-
-! way 2:
- do i=1,mod(NGLOB_OUTER_CORE,4)
- b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
- enddo
- do i=mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE,4
- b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
- b_accel_outer_core(i+1) = b_accel_outer_core(i+1)*rmass_outer_core(i+1)
- b_accel_outer_core(i+2) = b_accel_outer_core(i+2)*rmass_outer_core(i+2)
- b_accel_outer_core(i+3) = b_accel_outer_core(i+3)*rmass_outer_core(i+3)
-
- b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
- b_veloc_outer_core(i+1) = b_veloc_outer_core(i+1) + b_deltatover2*b_accel_outer_core(i+1)
- b_veloc_outer_core(i+2) = b_veloc_outer_core(i+2) + b_deltatover2*b_accel_outer_core(i+2)
- b_veloc_outer_core(i+3) = b_veloc_outer_core(i+3) + b_deltatover2*b_accel_outer_core(i+3)
- enddo
-
- endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the solid
- ! ****************************************************
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- iphase = 0 ! do not start any non blocking communications at this stage
- iphase_CC = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-!----------------------
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-!----------------------
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- if (SIMULATION_TYPE == 3 ) then
-
- b_iphase = 0 ! do not start any non blocking communications at this stage
- b_iphase_CC = 0 ! do not start any non blocking communications at this stage
- b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-!----------------------
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-!----------------------
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-!----------------------
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-!----------------------
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-
- endif
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-!----------------------
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-!----------------------
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
- if (SIMULATION_TYPE == 3) then
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-!----------------------
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-!----------------------
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-!----------------------
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-!----------------------
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
- endif
-
- ! Stacey
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- call compute_stacey_crust_mantle(ichunk,SIMULATION_TYPE, &
- NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
- veloc_crust_mantle,accel_crust_mantle,b_accel_crust_mantle, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
- wgllwgll_xz,wgllwgll_yz, &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
- normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
- rho_vp_crust_mantle,rho_vs_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
- ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- nimin_crust_mantle,nimax_crust_mantle, &
- njmin_crust_mantle,njmax_crust_mantle, &
- nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
- absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
- absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
- endif ! Stacey conditions
-
- ! add the sources
- if (SIMULATION_TYPE == 1) &
- call compute_add_sources(myrank,NSOURCES, &
- accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
- ! add adjoint sources
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- if( nadj_rec_local > 0 ) &
- call compute_add_sources_adjoint(myrank,nrec, &
- nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
- accel_crust_mantle,adj_sourcearrays, &
- nu,xi_receiver,eta_receiver,gamma_receiver, &
- xigll,yigll,zigll,ibool_crust_mantle, &
- islice_selected_rec,ispec_selected_rec, &
- NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
- it,it_begin,station_name,network_name,DT)
- endif
-
- ! add sources for backward/reconstructed wavefield
- if (SIMULATION_TYPE == 3) &
- call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
- b_accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
-!<YANGL
- ! NOISE_TOMOGRAPHY
- if ( NOISE_TOMOGRAPHY == 1 ) then
- ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
- ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
- ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
- ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
- call add_source_master_rec_noise(myrank,nrec, &
- NSTEP,accel_crust_mantle,noise_sourcearray, &
- ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
- it,irec_master_noise)
- elseif ( NOISE_TOMOGRAPHY == 2 ) then
- ! second step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to drive the ensemble forward wavefield
- call noise_read_add_surface_movie(myrank,nmovie_points,accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- store_val_ux,store_val_uy,store_val_uz, &
- ibelm_top_crust_mantle,ibool_crust_mantle,NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- NIT,NSTEP-it+1,LOCAL_PATH,jacobian2D_top_crust_mantle,wgllwgll_xy)
- ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
- ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
- ! note the ensemble forward sources are generally distributed on the surface of the earth
- ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
- ! therefore, we must add it here, before applying the inverse of mass matrix
- elseif ( NOISE_TOMOGRAPHY == 3 ) then
- ! third step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to reconstruct the ensemble forward wavefield
- ! the ensemble adjoint wavefield is done as usual
- ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
- call noise_read_add_surface_movie(myrank,nmovie_points,b_accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- store_val_ux,store_val_uy,store_val_uz, &
- ibelm_top_crust_mantle,ibool_crust_mantle,NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- NIT,it,LOCAL_PATH,jacobian2D_top_crust_mantle,wgllwgll_xy)
- endif
-!>YANGL
-
- ! ****************************************************
- ! ********** add matching with fluid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the solid
-
- !---
- !--- couple with outer core at the bottom of the mantle
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) &
- call compute_coupling_CMB_fluid(displ_crust_mantle,b_displ_crust_mantle, &
- accel_crust_mantle,b_accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- RHO_TOP_OC,minus_g_cmb, &
- SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
-
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) &
- call compute_coupling_ICB_fluid(displ_inner_core,b_displ_inner_core, &
- accel_inner_core,b_accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- RHO_BOTTOM_OC,minus_g_icb, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_INNER_CORE))
-
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- if(USE_NONBLOCKING_COMMS) then
-
- iphase = 1 ! initialize the non blocking communication counter
- iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-!----------------------
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-!----------------------
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-!----------------------
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-!----------------------
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
-!----------------------
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
- enddo
- else
- ! 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_block(myrank, &
- accel_crust_mantle,NGLOB_CRUST_MANTLE, &
- accel_inner_core,NGLOB_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,buffer_received_faces, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL, &
- NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
- NGLOB2DMAX_XY,NCHUNKS_VAL)
- endif
-
- !---
- !--- use buffers to assemble forces with the central cube
- !---
-
- if(INCLUDE_CENTRAL_CUBE) then
- if(USE_NONBLOCKING_COMMS) then
- do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),accel_inner_core,NDIM,iphase_CC)
- enddo
- else
- call assemble_MPI_central_cube_block(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
- endif ! end of assembling forces with the central cube
-
-! way 1:
-! do i=1,NGLOB_CRUST_MANTLE
-! accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
-! + two_omega_earth*veloc_crust_mantle(2,i)
-! accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
-! - two_omega_earth*veloc_crust_mantle(1,i)
-! accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmass_crust_mantle(i)
-! enddo
-
-! way 2:
- do i=1,mod(NGLOB_CRUST_MANTLE,4)
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmass_crust_mantle(i)
- enddo
- do i=mod(NGLOB_CRUST_MANTLE,4)+1,NGLOB_CRUST_MANTLE,4
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmass_crust_mantle(i)
-
- accel_crust_mantle(1,i+1) = accel_crust_mantle(1,i+1)*rmass_crust_mantle(i+1) &
- + two_omega_earth*veloc_crust_mantle(2,i+1)
- accel_crust_mantle(2,i+1) = accel_crust_mantle(2,i+1)*rmass_crust_mantle(i+1) &
- - two_omega_earth*veloc_crust_mantle(1,i+1)
- accel_crust_mantle(3,i+1) = accel_crust_mantle(3,i+1)*rmass_crust_mantle(i+1)
-
- accel_crust_mantle(1,i+2) = accel_crust_mantle(1,i+2)*rmass_crust_mantle(i+2) &
- + two_omega_earth*veloc_crust_mantle(2,i+2)
- accel_crust_mantle(2,i+2) = accel_crust_mantle(2,i+2)*rmass_crust_mantle(i+2) &
- - two_omega_earth*veloc_crust_mantle(1,i+2)
- accel_crust_mantle(3,i+2) = accel_crust_mantle(3,i+2)*rmass_crust_mantle(i+2)
-
- accel_crust_mantle(1,i+3) = accel_crust_mantle(1,i+3)*rmass_crust_mantle(i+3) &
- + two_omega_earth*veloc_crust_mantle(2,i+3)
- accel_crust_mantle(2,i+3) = accel_crust_mantle(2,i+3)*rmass_crust_mantle(i+3) &
- - two_omega_earth*veloc_crust_mantle(1,i+3)
- accel_crust_mantle(3,i+3) = accel_crust_mantle(3,i+3)*rmass_crust_mantle(i+3)
- enddo
-
- if (SIMULATION_TYPE == 3) then
-
-! ------------------- new non blocking implementation -------------------
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- if(USE_NONBLOCKING_COMMS) then
-
- b_iphase = 1 ! initialize the non blocking communication counter
- b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
-
- b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-!----------------------
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-!----------------------
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
-!----------------------
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-!----------------------
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-!----------------------
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-!----------------------
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
-!----------------------
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
-!----------------------
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (b_iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
- enddo
- else
- ! 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_block(myrank, &
- b_accel_crust_mantle,NGLOB_CRUST_MANTLE, &
- b_accel_inner_core,NGLOB_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, &
- b_buffer_send_faces,b_buffer_received_faces, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL, &
- NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
- NGLOB2DMAX_XY,NCHUNKS_VAL)
- endif
-
- !---
- !--- use buffers to assemble forces with the central cube
- !---
-
- if(INCLUDE_CENTRAL_CUBE) then
- if(USE_NONBLOCKING_COMMS) then
- do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
- enddo
- else
- call assemble_MPI_central_cube_block(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_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,b_accel_inner_core,NDIM)
- endif
- endif ! end of assembling forces with the central cube
-
-! ------------------- new non blocking implementation -------------------
-
-! way 1:
-! do i=1,NGLOB_CRUST_MANTLE
-! b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
-! + b_two_omega_earth*b_veloc_crust_mantle(2,i)
-! b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
-! - b_two_omega_earth*b_veloc_crust_mantle(1,i)
-! b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmass_crust_mantle(i)
-! enddo
-
-! way 2:
- do i=1,mod(NGLOB_CRUST_MANTLE,4)
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmass_crust_mantle(i)
- enddo
- do i=mod(NGLOB_CRUST_MANTLE,4)+1,NGLOB_CRUST_MANTLE,4
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmass_crust_mantle(i)
-
- b_accel_crust_mantle(1,i+1) = b_accel_crust_mantle(1,i+1)*rmass_crust_mantle(i+1) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i+1)
- b_accel_crust_mantle(2,i+1) = b_accel_crust_mantle(2,i+1)*rmass_crust_mantle(i+1) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i+1)
- b_accel_crust_mantle(3,i+1) = b_accel_crust_mantle(3,i+1)*rmass_crust_mantle(i+1)
-
- b_accel_crust_mantle(1,i+2) = b_accel_crust_mantle(1,i+2)*rmass_crust_mantle(i+2) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i+2)
- b_accel_crust_mantle(2,i+2) = b_accel_crust_mantle(2,i+2)*rmass_crust_mantle(i+2) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i+2)
- b_accel_crust_mantle(3,i+2) = b_accel_crust_mantle(3,i+2)*rmass_crust_mantle(i+2)
-
- b_accel_crust_mantle(1,i+3) = b_accel_crust_mantle(1,i+3)*rmass_crust_mantle(i+3) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i+3)
- b_accel_crust_mantle(2,i+3) = b_accel_crust_mantle(2,i+3)*rmass_crust_mantle(i+3) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i+3)
- b_accel_crust_mantle(3,i+3) = b_accel_crust_mantle(3,i+3)*rmass_crust_mantle(i+3)
- enddo
-
- endif
-
- ! couples ocean with crust mantle
- if(OCEANS_VAL) &
- call compute_coupling_ocean(accel_crust_mantle,b_accel_crust_mantle, &
- rmass_crust_mantle,rmass_ocean_load,normal_top_crust_mantle, &
- ibool_crust_mantle,ibelm_top_crust_mantle, &
- updated_dof_ocean_load, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_CRUST_MANTLE))
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
-! way 1:
-! 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) &
-! + two_omega_earth*veloc_inner_core(2,i)
-! accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
-! - two_omega_earth*veloc_inner_core(1,i)
-! accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-!
-! veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
-! enddo
-
-! way 2:
- do i=1,mod(NGLOB_CRUST_MANTLE,4)
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- enddo
- do i=mod(NGLOB_CRUST_MANTLE,4)+1,NGLOB_CRUST_MANTLE,4
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i+1) = veloc_crust_mantle(:,i+1) + deltatover2*accel_crust_mantle(:,i+1)
- veloc_crust_mantle(:,i+2) = veloc_crust_mantle(:,i+2) + deltatover2*accel_crust_mantle(:,i+2)
- veloc_crust_mantle(:,i+3) = veloc_crust_mantle(:,i+3) + deltatover2*accel_crust_mantle(:,i+3)
- enddo
-
- do i=1,mod(NGLOB_INNER_CORE,3)
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
- enddo
- do i=mod(NGLOB_INNER_CORE,3)+1,NGLOB_INNER_CORE,3
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- accel_inner_core(1,i+1) = accel_inner_core(1,i+1)*rmass_inner_core(i+1) &
- + two_omega_earth*veloc_inner_core(2,i+1)
- accel_inner_core(2,i+1) = accel_inner_core(2,i+1)*rmass_inner_core(i+1) &
- - two_omega_earth*veloc_inner_core(1,i+1)
- accel_inner_core(3,i+1) = accel_inner_core(3,i+1)*rmass_inner_core(i+1)
-
- accel_inner_core(1,i+2) = accel_inner_core(1,i+2)*rmass_inner_core(i+2) &
- + two_omega_earth*veloc_inner_core(2,i+2)
- accel_inner_core(2,i+2) = accel_inner_core(2,i+2)*rmass_inner_core(i+2) &
- - two_omega_earth*veloc_inner_core(1,i+2)
- accel_inner_core(3,i+2) = accel_inner_core(3,i+2)*rmass_inner_core(i+2)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
- veloc_inner_core(:,i+1) = veloc_inner_core(:,i+1) + deltatover2*accel_inner_core(:,i+1)
- veloc_inner_core(:,i+2) = veloc_inner_core(:,i+2) + deltatover2*accel_inner_core(:,i+2)
- enddo
-
- if (SIMULATION_TYPE == 3) then
-! way 1:
-! do i=1,NGLOB_CRUST_MANTLE
-! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
-! enddo
-!
-! do i=1,NGLOB_INNER_CORE
-! b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
-! + b_two_omega_earth*b_veloc_inner_core(2,i)
-! b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
-! - b_two_omega_earth*b_veloc_inner_core(1,i)
-! b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
-!
-! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
-! enddo
-
-! way 2:
- do i=1,mod(NGLOB_CRUST_MANTLE,4)
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
- enddo
- do i=mod(NGLOB_CRUST_MANTLE,4)+1,NGLOB_CRUST_MANTLE,4
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i+1) = b_veloc_crust_mantle(:,i+1) + b_deltatover2*b_accel_crust_mantle(:,i+1)
- b_veloc_crust_mantle(:,i+2) = b_veloc_crust_mantle(:,i+2) + b_deltatover2*b_accel_crust_mantle(:,i+2)
- b_veloc_crust_mantle(:,i+3) = b_veloc_crust_mantle(:,i+3) + b_deltatover2*b_accel_crust_mantle(:,i+3)
- enddo
-
- do i=1,mod(NGLOB_INNER_CORE,3)
- b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
- + b_two_omega_earth*b_veloc_inner_core(2,i)
- b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
- - b_two_omega_earth*b_veloc_inner_core(1,i)
- b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
-
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
- enddo
- do i=mod(NGLOB_INNER_CORE,3)+1,NGLOB_INNER_CORE,3
- b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
- + b_two_omega_earth*b_veloc_inner_core(2,i)
- b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
- - b_two_omega_earth*b_veloc_inner_core(1,i)
- b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
-
- b_accel_inner_core(1,i+1) = b_accel_inner_core(1,i+1)*rmass_inner_core(i+1) &
- + b_two_omega_earth*b_veloc_inner_core(2,i+1)
- b_accel_inner_core(2,i+1) = b_accel_inner_core(2,i+1)*rmass_inner_core(i+1) &
- - b_two_omega_earth*b_veloc_inner_core(1,i+1)
- b_accel_inner_core(3,i+1) = b_accel_inner_core(3,i+1)*rmass_inner_core(i+1)
-
- b_accel_inner_core(1,i+2) = b_accel_inner_core(1,i+2)*rmass_inner_core(i+2) &
- + b_two_omega_earth*b_veloc_inner_core(2,i+2)
- b_accel_inner_core(2,i+2) = b_accel_inner_core(2,i+2)*rmass_inner_core(i+2) &
- - b_two_omega_earth*b_veloc_inner_core(1,i+2)
- b_accel_inner_core(3,i+2) = b_accel_inner_core(3,i+2)*rmass_inner_core(i+2)
-
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i+1) = b_veloc_inner_core(:,i+1) + b_deltatover2*b_accel_inner_core(:,i+1)
- b_veloc_inner_core(:,i+2) = b_veloc_inner_core(:,i+2) + b_deltatover2*b_accel_inner_core(:,i+2)
- enddo
-
- endif
-
-
- ! restores last time snapshot saved for backward/reconstruction of wavefields
- ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
- ! and adjoint sources will become more complicated
- ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
- if( SIMULATION_TYPE == 3 .and. it == 1 ) then
- call read_forward_arrays(myrank, &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
- b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
- b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
- endif
-
-! write the seismograms with time shift
-
-! store the seismograms only if there is at least one receiver located in this slice
- if (nrec_local > 0) then
- if (SIMULATION_TYPE == 1) then
- call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- else if (SIMULATION_TYPE == 2) then
- call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- hxir_store,hetar_store,hgammar_store, &
- hpxir_store,hpetar_store,hpgammar_store, &
- tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
- hprime_xx,hprime_yy,hprime_zz, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- moment_der,sloc_der,stshift_der,shdur_der, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
- ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
- NSTEP,it,nit_written)
-
- else if (SIMULATION_TYPE == 3) then
- call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- endif
- endif ! nrec_local
-
- ! write the current or final seismograms
- if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,stbur, &
- nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
- yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
- elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
- cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE)
- if(myrank==0) then
- write(IMAIN,*)
- write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
- write(IMAIN,*)
- endif
- else
- if( nrec_local > 0 ) &
- call write_adj_seismograms(seismograms,number_receiver_global, &
- nrec_local,it,nit_written,DT, &
- NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
- nit_written = it
- endif
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
- endif
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
-! kernel calculations
- if (SIMULATION_TYPE == 3) then
- ! crust mantle
- call compute_kernels_crust_mantle(ibool_crust_mantle, &
- rho_kl_crust_mantle,beta_kl_crust_mantle, &
- alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
- accel_crust_mantle,b_displ_crust_mantle, &
- epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
- deltat)
-
- ! outer core
- call compute_kernels_outer_core(ibool_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- hprime_xx,hprime_yy,hprime_zz, &
- displ_outer_core,accel_outer_core, &
- b_displ_outer_core,b_accel_outer_core, &
- vector_accel_outer_core,vector_displ_outer_core, &
- b_vector_displ_outer_core, &
- div_displ_outer_core,b_div_displ_outer_core, &
- rhostore_outer_core,kappavstore_outer_core, &
- rho_kl_outer_core,alpha_kl_outer_core, &
- deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
- deltat)
-
- ! inner core
- call compute_kernels_inner_core(ibool_inner_core, &
- rho_kl_inner_core,beta_kl_inner_core, &
- alpha_kl_inner_core, &
- accel_inner_core,b_displ_inner_core, &
- epsilondev_inner_core,b_epsilondev_inner_core, &
- eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
- deltat)
-
-!<YANGL
- ! NOISE TOMOGRAPHY --- source strength kernel
- if (NOISE_TOMOGRAPHY == 3) &
- call compute_kernels_strength_noise(myrank,ibool_crust_mantle, &
- Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
- nmovie_points,normal_x_noise,normal_y_noise,normal_z_noise, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),ibelm_top_crust_mantle,LOCAL_PATH)
-!>YANGL
-
- ! --- boundary kernels ------
- if (SAVE_BOUNDARY_MESH) then
- fluid_solid_boundary = .false.
- iregion_code = IREGION_CRUST_MANTLE
-
- ! Moho
- if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
-
- moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
- endif
-
- ! 400
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
-
- d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
-
- ! 670
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
-
- d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
-
- ! CMB
- fluid_solid_boundary = .true.
- iregion_code = IREGION_CRUST_MANTLE
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
- cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
-
- iregion_code = IREGION_OUTER_CORE
- call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
- b_vector_displ_outer_core,nspec_outer_core, &
- iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,idoubling_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core,&
- gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_outer_core,kappavstore_outer_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_bot,ibelm_top_outer_core,normal_top_outer_core, &
- cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
-
- cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
-
- ! ICB
- fluid_solid_boundary = .true.
- call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
- b_vector_displ_outer_core,nspec_outer_core, &
- iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,idoubling_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core,&
- gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_outer_core,kappavstore_outer_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
- icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
-
- iregion_code = IREGION_INNER_CORE
- call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
- b_displ_inner_core,nspec_inner_core,iregion_code, &
- ystore_inner_core,zstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core,&
- gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
- dummy_array,dummy_array,dummy_array, &
- c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- c33store_inner_core,dummy_array,dummy_array, &
- dummy_array,c44store_inner_core,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
- icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
-
- icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
- endif
-
- ! approximate hessian
- if( APPROXIMATE_HESS_KL ) then
- call compute_kernels_hessian(ibool_crust_mantle, &
- hess_kl_crust_mantle,&
- accel_crust_mantle,b_accel_crust_mantle, &
- deltat)
- endif
-
- endif ! end computing kernels
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
-!<YANGL
- ! first step of noise tomography, i.e., save a surface movie at every time step
- ! modified from the subroutine 'write_movie_surface'
- if ( NOISE_TOMOGRAPHY == 1 ) then
- call noise_save_surface_movie(myrank,nmovie_points,displ_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- NIT,it,LOCAL_PATH)
- endif
-!>YANGL
-
- ! save movie on surface
- if( MOVIE_SURFACE ) then
- if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- ! save velocity here to avoid static offset on displacement for movies
- call write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- store_val_x,store_val_y,store_val_z, &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux,store_val_uy,store_val_uz, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- NIT,it,OUTPUT_FILES)
- endif
- endif
-
-
- ! save movie in full 3D mesh
- if(MOVIE_VOLUME ) then
- if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
- .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
-
- if (MOVIE_VOLUME_TYPE == 1) then ! output strains
-
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
- ! output the Time Integral of Strain, or \mu*TIS
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,Ieps_trace_over_3_crust_mantle,Iepsilondev_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 4) then ! output divergence and curl in whole volume
-
- call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
- div_displ_outer_core,eps_trace_over_3_inner_core,epsilondev_crust_mantle,&
- epsilondev_inner_core)
-
- else if (MOVIE_VOLUME_TYPE == 5) then !output displacement
- scalingval = scale_displ
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,displ_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 6) then !output velocity
- scalingval = scale_veloc
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,veloc_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- else
-
- stop 'MOVIE_VOLUME_TYPE has to be 1,2,3,4'
-
- endif ! MOVIE_VOLUME_TYPE
- endif
- endif ! MOVIE_VOLUME
-
-!---- end of time iteration loop
-!
- enddo ! end of main time loop
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
- ! synchronize all processes, waits until all processes have written their seismograms
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error synchronize after time loop')
-
- ! closes Stacey absorbing boundary snapshots
- if( ABSORBING_CONDITIONS ) then
- ! crust mantle
- if (nspec2D_xmin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(0)
- endif
-
- if (nspec2D_xmax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(1)
- endif
-
- if (nspec2D_ymin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(2)
- endif
-
- if (nspec2D_ymax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(3)
- endif
-
- ! outer core
- if (nspec2D_xmin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(4)
- endif
-
- if (nspec2D_xmax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(5)
- endif
-
- if (nspec2D_ymin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(6)
- endif
-
- if (nspec2D_ymax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(7)
- endif
-
- if (NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(8)
- endif
-
- endif
-
- ! synchronize all processes
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error synchronize closing snapshots')
-
- ! save files to local disk or tape system if restart file
- call save_forward_arrays(myrank,SIMULATION_TYPE,SAVE_FORWARD, &
- NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
- displ_inner_core,veloc_inner_core,accel_inner_core, &
- displ_outer_core,veloc_outer_core,accel_outer_core, &
- R_memory_crust_mantle,R_memory_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
- A_array_rotation,B_array_rotation, &
- LOCAL_PATH)
-
- ! synchronize all processes
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error synchronize saving forward')
-
- ! dump kernel arrays
- if (SIMULATION_TYPE == 3) then
- ! crust mantle
- call save_kernels_crust_mantle(myrank,scale_t,scale_displ, &
- cijkl_kl_crust_mantle,rho_kl_crust_mantle, &
- alpha_kl_crust_mantle,beta_kl_crust_mantle, &
- ystore_crust_mantle,zstore_crust_mantle, &
- rhostore_crust_mantle,muvstore_crust_mantle, &
- kappavstore_crust_mantle,ibool_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle, &
- eta_anisostore_crust_mantle,idoubling_crust_mantle, &
- LOCAL_PATH)
-
-!<YANGL
- ! noise strength kernel
- if (NOISE_TOMOGRAPHY == 3) then
- call save_kernels_strength_noise(myrank,LOCAL_PATH,Sigma_kl_crust_mantle)
- endif
-!>YANGL
-
- ! outer core
- call save_kernels_outer_core(myrank,scale_t,scale_displ, &
- rho_kl_outer_core,alpha_kl_outer_core, &
- rhostore_outer_core,kappavstore_outer_core, &
- deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
- LOCAL_PATH)
-
- ! inner core
- call save_kernels_inner_core(myrank,scale_t,scale_displ, &
- rho_kl_inner_core,beta_kl_inner_core,alpha_kl_inner_core, &
- rhostore_inner_core,muvstore_inner_core,kappavstore_inner_core, &
- LOCAL_PATH)
-
- ! boundary kernel
- if (SAVE_BOUNDARY_MESH) then
- call save_kernels_boundary_kl(myrank,scale_t,scale_displ, &
- moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl, &
- LOCAL_PATH,HONOR_1D_SPHERICAL_MOHO)
- endif
-
- ! approximate hessian
- if( APPROXIMATE_HESS_KL ) then
- call save_kernels_hessian(myrank,scale_t,scale_displ, &
- hess_kl_crust_mantle,LOCAL_PATH)
- endif
- endif
-
- ! save source derivatives for adjoint simulations
- if (SIMULATION_TYPE == 2 .and. nrec_local > 0) then
- call save_kernels_source_derivatives(nrec_local,NSOURCES,scale_displ,scale_t, &
- nu_source,moment_der,sloc_der,stshift_der,shdur_der,number_receiver_global)
- 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)
- if( ier /= 0 ) call exit_mpi(myrank,'error synchronize finishing simulation')
-
- ! stop all the MPI processes, and exit
- call MPI_FINALIZE(ier)
-
- end program xspecfem3D
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/spline_routines.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/spline_routines.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/spline_routines.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! compute 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/src/add_missing_nodes.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/add_missing_nodes.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_missing_nodes.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_missing_nodes.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute the 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 UTILS/chunk_notes_scanned/numbering_convention_27_nodes.tif
+
+ 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 UTILS/chunk_notes_scanned/numbering_convention_27_nodes.tif
+
+ 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/src/add_topography.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,172 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ !> Hejun
+ ! This subroutine uses GLL points to capture topography variation rather
+ ! than using control nodes
+ ! Hejun Zhu, OCT16, 2009
+
+ ! input parameters: myrank,
+ ! xstore,ystore,zstore,
+ ! ispec,nspec,
+ ! ibathy_topo
+ ! R220
+
+ subroutine add_topography_gll(myrank,xstore,ystore,zstore,ispec,nspec,&
+ ibathy_topo,R220)
+
+ implicit none
+
+ include "constants.h"
+
+ ! input parameters
+ integer:: myrank
+ integer:: ispec,nspec
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec):: xstore,ystore,zstore
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+ double precision:: R220
+
+ ! local parameters used in this subroutine
+ integer:: i,j,k
+ double precision:: r,theta,phi,colat
+ double precision:: lat,lon,elevation,gamma
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ ! convert to r theta phi
+ ! slightly move points to avoid roundoff problem when exactly on the polar axis
+ call xyz_2_rthetaphi_dble(xstore(i,j,k,ispec),ystore(i,j,k,ispec),zstore(i,j,k,ispec),&
+ 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 factor makes sense
+ if(gamma < -0.02 .or. gamma > 1.02) then
+ call exit_MPI(myrank,'incorrect value of factor for topography gll points')
+ end if
+ !
+
+ ! since not all GLL points are exactlly at R220, use a small
+ ! tolerance for R220 detection
+ if (abs(gamma) < SMALLVAL) then
+ gamma = 0.0
+ end if
+ xstore(i,j,k,ispec) = xstore(i,j,k,ispec)*(ONE + gamma * elevation / r)
+ ystore(i,j,k,ispec) = ystore(i,j,k,ispec)*(ONE + gamma * elevation / r)
+ zstore(i,j,k,ispec) = zstore(i,j,k,ispec)*(ONE + gamma * elevation / r)
+
+ end do
+ end do
+ end do
+ end subroutine add_topography_gll
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_410_650.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_410_650.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_410_650.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_410_650.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,249 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ !> Hejun
+ ! use GLL points to capture 410_650 topography
+ ! JAN08, 2010
+ subroutine add_topography_410_650_gll(myrank,xstore,ystore,zstore,ispec,nspec,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
+ integer:: ispec,nspec
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec):: xstore,ystore,zstore
+
+ double precision R220,R400,R670,R771
+
+ integer i,j,k
+
+ 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 GLL points of the element
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ ! convert to r theta phi
+ call xyz_2_rthetaphi_dble(xstore(i,j,k,ispec),ystore(i,j,k,ispec),zstore(i,j,k,ispec),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)
+ xstore(i,j,k,ispec) = xstore(i,j,k,ispec)*(ONE + gamma * topo410 / r)
+ ystore(i,j,k,ispec) = ystore(i,j,k,ispec)*(ONE + gamma * topo410 / r)
+ zstore(i,j,k,ispec) = zstore(i,j,k,ispec)*(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)
+ xstore(i,j,k,ispec) = xstore(i,j,k,ispec)*(ONE + gamma * topo650 / r)
+ ystore(i,j,k,ispec) = ystore(i,j,k,ispec)*(ONE + gamma * topo650 / r)
+ zstore(i,j,k,ispec) = zstore(i,j,k,ispec)*(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)
+ xstore(i,j,k,ispec) = xstore(i,j,k,ispec)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
+ ystore(i,j,k,ispec) = ystore(i,j,k,ispec)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
+ zstore(i,j,k,ispec) = zstore(i,j,k,ispec)*(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 do
+ end do
+
+ end subroutine add_topography_410_650_gll
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_cmb.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_cmb.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_cmb.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_cmb.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/add_topography_icb.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_icb.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_icb.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/add_topography_icb.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/assemble_MPI_central_cube.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_central_cube.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_central_cube.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_central_cube.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,328 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM_INNER_CORE,vector_assemble,ndim_assemble,iphase_CC)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include 'constants.h'
+
+! include values created by the mesher
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+! for matching with central cube in inner core
+ integer, intent(in) :: ichunk, nb_msgs_theor_in_cube, npoin2D_cube_from_slices
+ integer, intent(inout) :: iphase_CC
+ integer, dimension(nb_msgs_theor_in_cube), intent(in) :: sender_from_slices_to_cube
+ double precision, dimension(npoin2D_cube_from_slices,ndim_assemble), intent(inout) :: buffer_slices
+ double precision, dimension(npoin2D_cube_from_slices,ndim_assemble,nb_msgs_theor_in_cube), intent(inout) :: &
+ buffer_all_cube_from_slices
+ integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices), intent(in) :: ibool_central_cube
+ integer, intent(in) :: receiver_cube_from_slices
+
+! local to global mapping
+ integer, intent(in) :: NSPEC2D_BOTTOM_INNER_CORE
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE), intent(in) :: ibool_inner_core
+ integer, dimension(NSPEC_INNER_CORE), intent(in) :: idoubling_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_INNER_CORE), intent(in) :: ibelm_bottom_inner_core
+
+! vector
+ integer, intent(in) :: ndim_assemble
+ real(kind=CUSTOM_REAL), dimension(ndim_assemble,NGLOB_INNER_CORE), intent(inout) :: 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, save :: request_send,request_receive
+! maximum value of nb_msgs_theor_in_cube is 5 (when NPROC_XI == 1)
+! therefore NPROC_XI+4 is always large enough
+ integer, dimension(NPROC_XI_VAL+4), save :: request_send_array,request_receive_array
+ logical :: flag_result_test
+ integer, dimension(MPI_STATUS_SIZE) :: msg_status
+ integer :: ier
+
+! mask
+ logical, dimension(NGLOB_INNER_CORE) :: mask
+
+!---
+!--- use buffers to assemble mass matrix with central cube once and for all
+!---
+
+ if(iphase_CC == 1) then
+
+! 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_IRECV(buffer_all_cube_from_slices(:,:,imsg), &
+ ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
+ itag,MPI_COMM_WORLD,request_receive_array(imsg),ier)
+ 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,:) = 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_ISSEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
+ MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,request_send,ier)
+ endif ! end sending info to central cube
+
+ iphase_CC = iphase_CC + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase_CC 1
+
+ if(iphase_CC == 2) then
+
+ if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
+ call MPI_TEST(request_send,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ endif
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+ do imsg = 1,nb_msgs_theor_in_cube-1
+ call MPI_TEST(request_receive_array(imsg),flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+ enddo
+ endif
+
+! 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,:) = 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)
+
+ call MPI_IRECV(buffer_all_cube_from_slices(:,:,nb_msgs_theor_in_cube), &
+ ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender,itag,MPI_COMM_WORLD,request_receive,ier)
+!! DK DK this merged with previous statement
+! buffer_all_cube_from_slices(:,:,nb_msgs_theor_in_cube) = buffer_slices2(:,:)
+
+ call MPI_ISSEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,receiver_cube_from_slices, &
+ itag,MPI_COMM_WORLD,request_send,ier)
+ endif
+
+ iphase_CC = iphase_CC + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase_CC 2
+
+ if(iphase_CC == 3) then
+
+!--- now we need to assemble the contributions
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ call MPI_TEST(request_send,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+
+ 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(ipoin,idimension,imsg))
+ else
+ array_central_cube(ibool_central_cube(imsg,ipoin)) = buffer_all_cube_from_slices(ipoin,idimension,imsg)
+ 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(ipoin,idimension,nb_msgs_theor_in_cube))
+ 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(ipoin,idimension,nb_msgs_theor_in_cube)
+ 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(ipoin,idimension,imsg) = 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_IRECV(buffer_slices, &
+ ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
+ itag,MPI_COMM_WORLD,request_receive,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(:,ibool_inner_core(i,j,k,ispec)) = sngl(buffer_slices(ipoin,:))
+! else
+! vector_assemble(:,ibool_inner_core(i,j,k,ispec)) = buffer_slices(ipoin,:)
+! 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
+! send buffers to slices
+ receiver = sender_from_slices_to_cube(imsg)
+ call MPI_ISSEND(buffer_all_cube_from_slices(:,:,imsg),ndim_assemble*npoin2D_cube_from_slices, &
+ MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,request_send_array(imsg),ier)
+ enddo
+ endif
+
+ iphase_CC = iphase_CC + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase_CC 3
+
+ if(iphase_CC == 4) then
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+ do imsg = 1,nb_msgs_theor_in_cube-1
+ call MPI_TEST(request_send_array(imsg),flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ enddo
+ endif
+
+ if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
+ call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+ 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
+! 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,:))
+ else
+ vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)) = buffer_slices(ipoin,:)
+ endif
+ enddo
+ enddo
+ enddo
+ endif ! end receiving info from central cube
+
+! this is the exit condition, to go beyond the last phase number
+ iphase_CC = iphase_CC + 1
+
+ endif !!!!!!!!! end of iphase_CC 4
+
+ end subroutine assemble_MPI_central_cube
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_central_cube_block.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_central_cube_block.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_central_cube_block.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_central_cube_block.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,263 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine assemble_MPI_central_cube_block(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)
+
+! this version of the routine is based on blocking MPI calls
+
+ 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_block
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_scalar.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_scalar.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_scalar.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_scalar.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,574 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!----
+!---- 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, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NCHUNKS,iphase)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer myrank,nglob,NCHUNKS,iphase
+
+! array to assemble
+ real(kind=CUSTOM_REAL), dimension(nglob), intent(inout) :: array_val
+
+ integer, intent(in) :: iproc_xi,iproc_eta,ichunk
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR), intent(in) :: npoin2D_xi,npoin2D_eta
+ integer, intent(in) :: npoin2D_faces(NUMFACES_SHARED)
+
+ integer, intent(in) :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY
+ integer, intent(in) :: NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL
+ integer, intent(in) :: NUMMSGS_FACES,NCORNERSCHUNKS
+
+! for addressing of the slices
+ integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1), intent(in) :: addressing
+
+! 2-D addressing and buffers for summation between slices
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX), intent(in) :: iboolleft_xi,iboolright_xi
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX), intent(in) :: iboolleft_eta,iboolright_eta
+
+! indirect addressing for each corner of the chunks
+ integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED), intent(in) :: iboolcorner
+ integer icount_corners
+
+ integer, intent(in) :: npoin2D_max_all_CM_IC
+ integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED), intent(in) :: iboolfaces
+ real(kind=CUSTOM_REAL), dimension(npoin2D_max_all_CM_IC,NUMFACES_SHARED), intent(inout) :: 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), intent(inout) :: buffer_send_chunkcorn_scalar, &
+ buffer_recv_chunkcorn_scalar
+
+! ---- arrays to assemble between chunks
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES), intent(in) :: iprocfrom_faces,iprocto_faces
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS), intent(in) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+! MPI status of messages to be received
+ integer, dimension(MPI_STATUS_SIZE) :: msg_status
+
+ integer :: ipoin,ipoin2D,ipoin1D
+ integer :: sender,receiver
+ integer :: imsg
+ integer :: icount_faces,npoin2D_chunks
+
+ integer :: ier
+! do not remove the "save" statement because this routine is non blocking
+ integer, save :: request_send,request_receive
+ integer, dimension(NUMFACES_SHARED), save :: request_send_array,request_receive_array
+ logical :: flag_result_test
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! check flag to see if we need to assemble (might be turned off when debugging)
+ if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) then
+ iphase = 9999 ! this means everything is finished
+ return
+ endif
+
+! 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
+!----
+
+ if(iphase == 1) then
+
+! slices copy the right face into the buffer
+ do ipoin=1,npoin2D_xi(2)
+ buffer_send_faces_scalar(ipoin,1) = 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_IRECV(buffer_received_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive,ier)
+
+ call MPI_ISSEND(buffer_send_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,receiver, &
+ itag2,MPI_COMM_WORLD,request_send,ier)
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 1
+
+ if(iphase == 2) then
+
+! call MPI_WAIT(request_send,msg_status,ier)
+! call MPI_WAIT(request_receive,msg_status,ier)
+ call MPI_TEST(request_send,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+
+! 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,1)
+ 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,1) = 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_IRECV(buffer_received_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive,ier)
+
+ call MPI_ISSEND(buffer_send_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,receiver, &
+ itag2,MPI_COMM_WORLD,request_send,ier)
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 2
+
+ if(iphase == 3) then
+
+! call MPI_WAIT(request_send,msg_status,ier)
+! call MPI_WAIT(request_receive,msg_status,ier)
+ call MPI_TEST(request_send,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+
+! 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,1)
+ enddo
+ endif
+
+!----
+!---- then assemble along eta using the 2-D topology
+!----
+
+! slices copy the right face into the buffer
+ do ipoin=1,npoin2D_eta(2)
+ buffer_send_faces_scalar(ipoin,1) = 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_IRECV(buffer_received_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive,ier)
+
+ call MPI_ISSEND(buffer_send_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,receiver, &
+ itag2,MPI_COMM_WORLD,request_send,ier)
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 3
+
+ if(iphase == 4) then
+
+! call MPI_WAIT(request_send,msg_status,ier)
+! call MPI_WAIT(request_receive,msg_status,ier)
+ call MPI_TEST(request_send,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+
+! 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,1)
+ 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,1) = 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_IRECV(buffer_received_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive,ier)
+
+ call MPI_ISSEND(buffer_send_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,receiver, &
+ itag2,MPI_COMM_WORLD,request_send,ier)
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 4
+
+ if(iphase == 5) then
+
+! call MPI_WAIT(request_send,msg_status,ier)
+! call MPI_WAIT(request_receive,msg_status,ier)
+ call MPI_TEST(request_send,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+
+! 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,1)
+ enddo
+ 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) then
+ iphase = 9999 ! this means everything is finished
+ return
+ endif
+
+! ***************************************************************
+! transmit messages in forward direction (iprocfrom -> iprocto)
+! ***************************************************************
+
+!---- 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==iprocto_faces(imsg)) then
+ sender = iprocfrom_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+ call MPI_IRECV(buffer_received_faces_scalar(:,icount_faces), &
+ npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive_array(icount_faces),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)) then
+ receiver = iprocto_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+ do ipoin2D=1,npoin2D_chunks
+ buffer_send_faces_scalar(ipoin2D,icount_faces) = array_val(iboolfaces(ipoin2D,icount_faces))
+ enddo
+ call MPI_ISSEND(buffer_send_faces_scalar(:,icount_faces),npoin2D_chunks, &
+ CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,request_send_array(icount_faces),ier)
+ endif
+ enddo
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 5
+
+ if(iphase == 6) then
+
+ 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)) then
+ call MPI_TEST(request_receive_array(icount_faces),flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+ endif
+ enddo
+
+ 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)) then
+ call MPI_TEST(request_send_array(icount_faces),flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ endif
+ enddo
+
+ 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)) then
+ do ipoin2D=1,npoin2D_faces(icount_faces)
+ array_val(iboolfaces(ipoin2D,icount_faces)) = &
+ array_val(iboolfaces(ipoin2D,icount_faces)) + buffer_received_faces_scalar(ipoin2D,icount_faces)
+ enddo
+ 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)) then
+ sender = iprocto_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+ call MPI_IRECV(buffer_received_faces_scalar(:,icount_faces), &
+ npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive_array(icount_faces),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)) then
+ receiver = iprocfrom_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+ do ipoin2D=1,npoin2D_chunks
+ buffer_send_faces_scalar(ipoin2D,icount_faces) = array_val(iboolfaces(ipoin2D,icount_faces))
+ enddo
+ call MPI_ISSEND(buffer_send_faces_scalar(:,icount_faces),npoin2D_chunks, &
+ CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,request_send_array(icount_faces),ier)
+ endif
+ enddo
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 6
+
+ if(iphase == 7) then
+
+ 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)) then
+ call MPI_TEST(request_send_array(icount_faces),flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+ endif
+ enddo
+
+ 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)) then
+ call MPI_TEST(request_receive_array(icount_faces),flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ endif
+ enddo
+
+ 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)) then
+ do ipoin2D=1,npoin2D_faces(icount_faces)
+ array_val(iboolfaces(ipoin2D,icount_faces)) = buffer_received_faces_scalar(ipoin2D,icount_faces)
+ enddo
+ endif
+ enddo
+
+! this is the exit condition, to go beyond the last phase number
+ iphase = iphase + 1
+
+!! DK DK do the rest in blocking for now, for simplicity
+
+!----
+!---- 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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
+ enddo
+ call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
+ enddo
+
+! send to worker #1
+ receiver = iproc_worker1_corners(imsg)
+ call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
+ receiver,itag,MPI_COMM_WORLD,ier)
+ endif
+
+ endif
+
+ enddo
+
+ endif !!!!!!!!! end of iphase 7
+
+ end subroutine assemble_MPI_scalar
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_scalar_block.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_scalar_block.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_scalar_block.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_scalar_block.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,439 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!----
+!---- assemble the contributions between slices and chunks using MPI
+!----
+
+ subroutine assemble_MPI_scalar_block(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_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NCHUNKS)
+
+! this version of the routine is based on blocking MPI calls
+
+ 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_CM_IC
+ integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
+ real(kind=CUSTOM_REAL), dimension(npoin2D_max_all_CM_IC) :: 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_chunkcorn_scalar,buffer_recv_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
+ enddo
+ call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
+ enddo
+
+! send to worker #1
+ receiver = iproc_worker1_corners(imsg)
+ call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
+ receiver,itag,MPI_COMM_WORLD,ier)
+ endif
+
+ endif
+
+ enddo
+
+ end subroutine assemble_MPI_scalar_block
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_vector.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_vector.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_vector.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_vector.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,890 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!----
+!---- 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, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces_vector,buffer_received_faces_vector,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL_crust_mantle, &
+ NGLOB1D_RADIAL_inner_core,NCHUNKS,iphase)
+
+ 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,iphase
+
+! the two arrays to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE), intent(inout) :: accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE), intent(inout) :: accel_inner_core
+
+ integer, intent(in) :: iproc_xi,iproc_eta,ichunk
+ integer, intent(in) :: npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer, intent(in) :: npoin2D_faces_inner_core(NUMFACES_SHARED)
+
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR), intent(in) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ npoin2D_xi_inner_core,npoin2D_eta_inner_core
+
+ integer, intent(in) :: NGLOB1D_RADIAL_crust_mantle,NGLOB1D_RADIAL_inner_core,NPROC_XI,NPROC_ETA
+ integer, intent(in) :: NUMMSGS_FACES,NCORNERSCHUNKS
+
+! for addressing of the slices
+ integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1), intent(in) :: addressing
+
+! 2-D addressing and buffers for summation between slices
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM), intent(in) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM), intent(in) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC), intent(in) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC), intent(in) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
+
+! indirect addressing for each corner of the chunks
+ integer, dimension(NGLOB1D_RADIAL_crust_mantle,NUMCORNERS_SHARED), intent(in) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_inner_core,NUMCORNERS_SHARED), intent(in) :: iboolcorner_inner_core
+ integer icount_corners
+
+ integer, intent(in) :: npoin2D_max_all_CM_IC
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED), intent(in) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED), intent(in) :: iboolfaces_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED), intent(inout) :: &
+ 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), intent(inout) :: &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector
+
+! ---- arrays to assemble between chunks
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES), intent(in) :: iprocfrom_faces,iprocto_faces
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS), intent(in) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+! MPI status of messages to be received
+ integer, dimension(MPI_STATUS_SIZE) :: msg_status
+
+ integer :: ipoin,ipoin2D,ipoin1D
+ integer :: sender,receiver
+ integer :: imsg
+ integer :: icount_faces,npoin2D_chunks_all
+
+ integer :: NGLOB1D_RADIAL_all
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_all,npoin2D_eta_all
+
+! do not remove the "save" statement because this routine is non blocking
+! therefore it needs to find the right value of ioffset when it re-enters
+! the routine later to perform the next communication step
+ integer, save :: ioffset
+
+ integer :: ier
+! do not remove the "save" statement because this routine is non blocking
+ integer, save :: request_send,request_receive
+ integer, dimension(NUMFACES_SHARED), save :: request_send_array,request_receive_array
+ logical :: flag_result_test
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! check flag to see if we need to assemble (might be turned off when debugging)
+ if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) then
+ iphase = 9999 ! this means everything is finished
+ return
+ endif
+
+! 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
+!----
+
+!----
+!---- first assemble along xi using the 2-D topology
+!----
+
+ if(iphase == 1) then
+
+! slices copy the right face into the buffer
+ do ipoin = 1,npoin2D_xi_crust_mantle(2)
+ buffer_send_faces_vector(1,ipoin,1) = accel_crust_mantle(1,iboolright_xi_crust_mantle(ipoin))
+ buffer_send_faces_vector(2,ipoin,1) = accel_crust_mantle(2,iboolright_xi_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin,1) = accel_crust_mantle(3,iboolright_xi_crust_mantle(ipoin))
+ enddo
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_xi_crust_mantle(2)
+
+ do ipoin = 1,npoin2D_xi_inner_core(2)
+ buffer_send_faces_vector(1,ioffset + ipoin,1) = accel_inner_core(1,iboolright_xi_inner_core(ipoin))
+ buffer_send_faces_vector(2,ioffset + ipoin,1) = accel_inner_core(2,iboolright_xi_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin,1) = accel_inner_core(3,iboolright_xi_inner_core(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_IRECV(buffer_received_faces_vector,NDIM*npoin2D_xi_all(1),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive,ier)
+
+ call MPI_ISSEND(buffer_send_faces_vector,NDIM*npoin2D_xi_all(2),CUSTOM_MPI_TYPE,receiver, &
+ itag2,MPI_COMM_WORLD,request_send,ier)
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 1
+
+ if(iphase == 2) then
+
+! call MPI_WAIT(request_send,msg_status,ier)
+! call MPI_WAIT(request_receive,msg_status,ier)
+ call MPI_TEST(request_send,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+
+! 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(1)
+ accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(1,ipoin,1)
+ accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(2,ipoin,1)
+ accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(3,ipoin,1)
+ enddo
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_xi_crust_mantle(1)
+
+ do ipoin = 1,npoin2D_xi_inner_core(1)
+ accel_inner_core(1,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(1,iboolleft_xi_inner_core(ipoin)) + &
+ buffer_received_faces_vector(1,ioffset + ipoin,1)
+ 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,1)
+ 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,1)
+ 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(1)
+ buffer_send_faces_vector(1,ipoin,1) = accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin))
+ buffer_send_faces_vector(2,ipoin,1) = accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin,1) = accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin))
+ enddo
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_xi_crust_mantle(1)
+
+ do ipoin = 1,npoin2D_xi_inner_core(1)
+ buffer_send_faces_vector(1,ioffset + ipoin,1) = accel_inner_core(1,iboolleft_xi_inner_core(ipoin))
+ buffer_send_faces_vector(2,ioffset + ipoin,1) = accel_inner_core(2,iboolleft_xi_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin,1) = accel_inner_core(3,iboolleft_xi_inner_core(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_IRECV(buffer_received_faces_vector,NDIM*npoin2D_xi_all(2),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive,ier)
+
+ call MPI_ISSEND(buffer_send_faces_vector,NDIM*npoin2D_xi_all(1),CUSTOM_MPI_TYPE,receiver, &
+ itag2,MPI_COMM_WORLD,request_send,ier)
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 2
+
+ if(iphase == 3) then
+
+! call MPI_WAIT(request_send,msg_status,ier)
+! call MPI_WAIT(request_receive,msg_status,ier)
+ call MPI_TEST(request_send,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+
+! 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(2)
+ accel_crust_mantle(1,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin,1)
+ accel_crust_mantle(2,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(2,ipoin,1)
+ accel_crust_mantle(3,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(3,ipoin,1)
+ enddo
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_xi_crust_mantle(2)
+
+ do ipoin = 1,npoin2D_xi_inner_core(2)
+ accel_inner_core(1,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin,1)
+ accel_inner_core(2,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(2,ioffset + ipoin,1)
+ accel_inner_core(3,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(3,ioffset + ipoin,1)
+ enddo
+
+ endif
+
+!----
+!---- then assemble along eta using the 2-D topology
+!----
+
+! slices copy the right face into the buffer
+ do ipoin = 1,npoin2D_eta_crust_mantle(2)
+ buffer_send_faces_vector(1,ipoin,1) = accel_crust_mantle(1,iboolright_eta_crust_mantle(ipoin))
+ buffer_send_faces_vector(2,ipoin,1) = accel_crust_mantle(2,iboolright_eta_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin,1) = accel_crust_mantle(3,iboolright_eta_crust_mantle(ipoin))
+ enddo
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_eta_crust_mantle(2)
+
+ do ipoin = 1,npoin2D_eta_inner_core(2)
+ buffer_send_faces_vector(1,ioffset + ipoin,1) = accel_inner_core(1,iboolright_eta_inner_core(ipoin))
+ buffer_send_faces_vector(2,ioffset + ipoin,1) = accel_inner_core(2,iboolright_eta_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin,1) = accel_inner_core(3,iboolright_eta_inner_core(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_IRECV(buffer_received_faces_vector,NDIM*npoin2D_eta_all(1),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive,ier)
+
+ call MPI_ISSEND(buffer_send_faces_vector,NDIM*npoin2D_eta_all(2),CUSTOM_MPI_TYPE,receiver, &
+ itag2,MPI_COMM_WORLD,request_send,ier)
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 3
+
+ if(iphase == 4) then
+
+! call MPI_WAIT(request_send,msg_status,ier)
+! call MPI_WAIT(request_receive,msg_status,ier)
+ call MPI_TEST(request_send,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+
+! 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(1)
+ accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(1,ipoin,1)
+ accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(2,ipoin,1)
+ accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(3,ipoin,1)
+ enddo
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_eta_crust_mantle(1)
+
+ do ipoin = 1,npoin2D_eta_inner_core(1)
+ accel_inner_core(1,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(1,iboolleft_eta_inner_core(ipoin)) + &
+ buffer_received_faces_vector(1,ioffset + ipoin,1)
+ 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,1)
+ 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,1)
+ 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(1)
+ buffer_send_faces_vector(1,ipoin,1) = accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin))
+ buffer_send_faces_vector(2,ipoin,1) = accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin,1) = accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin))
+ enddo
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_eta_crust_mantle(1)
+
+ do ipoin = 1,npoin2D_eta_inner_core(1)
+ buffer_send_faces_vector(1,ioffset + ipoin,1) = accel_inner_core(1,iboolleft_eta_inner_core(ipoin))
+ buffer_send_faces_vector(2,ioffset + ipoin,1) = accel_inner_core(2,iboolleft_eta_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin,1) = accel_inner_core(3,iboolleft_eta_inner_core(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_IRECV(buffer_received_faces_vector,NDIM*npoin2D_eta_all(2),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive,ier)
+
+ call MPI_ISSEND(buffer_send_faces_vector,NDIM*npoin2D_eta_all(1),CUSTOM_MPI_TYPE,receiver, &
+ itag2,MPI_COMM_WORLD,request_send,ier)
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 4
+
+ if(iphase == 5) then
+
+! call MPI_WAIT(request_send,msg_status,ier)
+! call MPI_WAIT(request_receive,msg_status,ier)
+ call MPI_TEST(request_send,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ call MPI_TEST(request_receive,flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+
+! 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(2)
+ accel_crust_mantle(1,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin,1)
+ accel_crust_mantle(2,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(2,ipoin,1)
+ accel_crust_mantle(3,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(3,ipoin,1)
+ enddo
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_eta_crust_mantle(2)
+
+ do ipoin = 1,npoin2D_eta_inner_core(2)
+ accel_inner_core(1,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin,1)
+ accel_inner_core(2,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(2,ioffset + ipoin,1)
+ accel_inner_core(3,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(3,ioffset + ipoin,1)
+ enddo
+
+ 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) then
+ iphase = 9999 ! this means everything is finished
+ return
+ endif
+
+! ***************************************************************
+! transmit messages in forward direction (iprocfrom -> iprocto)
+! ***************************************************************
+
+!---- 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==iprocto_faces(imsg)) 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)
+
+ call MPI_IRECV(buffer_received_faces_vector(:,:,icount_faces),NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive_array(icount_faces),ier)
+
+! do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+! accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
+! accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ipoin2D,icount_faces)
+! 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,icount_faces)
+! 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,icount_faces)
+! enddo
+
+! 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_inner_core(icount_faces)
+! accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+! accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) + &
+! buffer_received_faces_vector(1,ioffset + ipoin2D,icount_faces)
+! 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,icount_faces)
+! 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,icount_faces)
+! 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)) 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)
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ buffer_send_faces_vector(1,ipoin2D,icount_faces) = accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ buffer_send_faces_vector(2,ipoin2D,icount_faces) = accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ipoin2D,icount_faces) = accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ enddo
+
+! 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_inner_core(icount_faces)
+ buffer_send_faces_vector(1,ioffset + ipoin2D,icount_faces) = accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces))
+ buffer_send_faces_vector(2,ioffset + ipoin2D,icount_faces) = accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ioffset + ipoin2D,icount_faces) = accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces))
+ enddo
+
+ call MPI_ISSEND(buffer_send_faces_vector(:,:,icount_faces),NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,receiver,itag, &
+ MPI_COMM_WORLD,request_send_array(icount_faces),ier)
+ endif
+ enddo
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 5
+
+ if(iphase == 6) then
+
+ 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)) then
+ call MPI_TEST(request_receive_array(icount_faces),flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+ endif
+ enddo
+
+ 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)) then
+ call MPI_TEST(request_send_array(icount_faces),flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ endif
+ enddo
+
+ 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)) then
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
+ accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ipoin2D,icount_faces)
+ 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,icount_faces)
+ 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,icount_faces)
+ enddo
+
+! 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_inner_core(icount_faces)
+ accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) + &
+ buffer_received_faces_vector(1,ioffset + ipoin2D,icount_faces)
+ 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,icount_faces)
+ 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,icount_faces)
+ enddo
+
+ 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)) 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)
+
+ call MPI_IRECV(buffer_received_faces_vector(:,:,icount_faces),NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,request_receive_array(icount_faces),ier)
+
+! do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+! accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ipoin2D,icount_faces)
+! accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(2,ipoin2D,icount_faces)
+! accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(3,ipoin2D,icount_faces)
+! enddo
+
+! 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_inner_core(icount_faces)
+! accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+! buffer_received_faces_vector(1,ioffset + ipoin2D,icount_faces)
+! accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+! buffer_received_faces_vector(2,ioffset + ipoin2D,icount_faces)
+! accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+! buffer_received_faces_vector(3,ioffset + ipoin2D,icount_faces)
+! 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)) 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)
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ buffer_send_faces_vector(1,ipoin2D,icount_faces) = accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ buffer_send_faces_vector(2,ipoin2D,icount_faces) = accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ipoin2D,icount_faces) = accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ enddo
+
+! 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_inner_core(icount_faces)
+ buffer_send_faces_vector(1,ioffset + ipoin2D,icount_faces) = accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces))
+ buffer_send_faces_vector(2,ioffset + ipoin2D,icount_faces) = accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ioffset + ipoin2D,icount_faces) = accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces))
+ enddo
+
+ call MPI_ISSEND(buffer_send_faces_vector(:,:,icount_faces),NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,receiver,itag, &
+ MPI_COMM_WORLD,request_send_array(icount_faces),ier)
+ endif
+ enddo
+
+ iphase = iphase + 1
+ return ! exit because we have started some communications therefore we need some time
+
+ endif !!!!!!!!! end of iphase 6
+
+ if(iphase == 7) then
+
+ 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)) then
+ call MPI_TEST(request_send_array(icount_faces),flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not received yet
+ endif
+ enddo
+
+ 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)) then
+ call MPI_TEST(request_receive_array(icount_faces),flag_result_test,msg_status,ier)
+ if(.not. flag_result_test) return ! exit if message not sent yet
+ endif
+ enddo
+
+ 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)) then
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ipoin2D,icount_faces)
+ accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(2,ipoin2D,icount_faces)
+ accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(3,ipoin2D,icount_faces)
+ enddo
+
+! 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_inner_core(icount_faces)
+ accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ buffer_received_faces_vector(1,ioffset + ipoin2D,icount_faces)
+ accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ buffer_received_faces_vector(2,ioffset + ipoin2D,icount_faces)
+ accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ buffer_received_faces_vector(3,ioffset + ipoin2D,icount_faces)
+ enddo
+ endif
+ enddo
+
+! this is the exit condition, to go beyond the last phase number
+ iphase = iphase + 1
+
+!! DK DK do the rest in blocking for now, for simplicity
+
+!----
+!---- 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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ buffer_send_chunkcorn_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(3,ioffset + ipoin1D) = accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners))
+ enddo
+
+ call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_vector(1,ipoin1D)
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(2,ipoin1D)
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(3,ipoin1D)
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(1,ioffset + ipoin1D)
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(2,ioffset + ipoin1D)
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_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_chunkcorn_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ buffer_send_chunkcorn_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif
+
+ endif
+
+ enddo
+
+ endif !!!!!!!!! end of iphase 7
+
+ end subroutine assemble_MPI_vector
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_vector_block.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/assemble_MPI_vector_block.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_vector_block.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/assemble_MPI_vector_block.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,707 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!----
+!---- 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_block(myrank, &
+ accel_crust_mantle,NGLOB_CRUST_MANTLE, &
+ accel_inner_core,NGLOB_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, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA, &
+ NGLOB1D_RADIAL_crust_mantle, &
+ NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM, &
+ NGLOB1D_RADIAL_inner_core, &
+ NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC, &
+ NGLOB2DMAX_XY,NCHUNKS)
+
+! this version of the routine is based on blocking MPI calls
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer myrank,NGLOB_CRUST_MANTLE,NGLOB_INNER_CORE,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, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
+ integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
+ integer npoin2D_faces_inner_core(NUMFACES_SHARED)
+
+ integer NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM,NGLOB1D_RADIAL_crust_mantle
+ integer NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC,NGLOB1D_RADIAL_inner_core
+ integer NPROC_XI,NPROC_ETA,NGLOB2DMAX_XY
+ 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_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, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces_crust_mantle,iboolfaces_inner_core
+! size of buffers is multiplied by 2 because we handle two regions in the same MPI call
+ real(kind=CUSTOM_REAL), dimension(NDIM,2*NGLOB2DMAX_XY) :: 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_chunkcorn_vector,buffer_recv_chunkcorn_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
+ integer icount_faces,npoin2D_chunks_all
+
+ integer :: NGLOB1D_RADIAL_all,ioffset
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_all,npoin2D_eta_all
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! 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
+!----
+
+!----
+!---- 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
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_xi_crust_mantle(2)
+
+ do ipoin = 1,npoin2D_xi_crust_mantle(2)
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolright_xi_crust_mantle(ipoin))
+ 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))
+ enddo
+
+ do ipoin = 1,npoin2D_xi_inner_core(2)
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolright_xi_inner_core(ipoin))
+ 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))
+ 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*npoin2D_xi_all(2),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM*npoin2D_xi_all(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_crust_mantle(1)
+ accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(1,ipoin)
+ 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)
+ enddo
+
+ ioffset = npoin2D_xi_crust_mantle(1)
+ do ipoin = 1,npoin2D_xi_inner_core(1)
+ accel_inner_core(1,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(1,iboolleft_xi_inner_core(ipoin)) + &
+ buffer_received_faces_vector(1,ioffset + ipoin)
+ 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)
+ 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
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_xi_crust_mantle(1)
+
+ do ipoin = 1,npoin2D_xi_crust_mantle(1)
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin))
+ 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))
+ enddo
+
+ do ipoin = 1,npoin2D_xi_inner_core(1)
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolleft_xi_inner_core(ipoin))
+ 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))
+ 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*npoin2D_xi_all(1),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM*npoin2D_xi_all(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_crust_mantle(2)
+ accel_crust_mantle(1,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin)
+ 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)
+ enddo
+
+ ioffset = npoin2D_xi_crust_mantle(2)
+ do ipoin = 1,npoin2D_xi_inner_core(2)
+ accel_inner_core(1,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin)
+ 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)
+ 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(2)
+
+! slices copy the right face into the buffer
+ do ipoin = 1,npoin2D_eta_crust_mantle(2)
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolright_eta_crust_mantle(ipoin))
+ 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))
+ enddo
+
+ do ipoin = 1,npoin2D_eta_inner_core(2)
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolright_eta_inner_core(ipoin))
+ 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))
+ 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*npoin2D_eta_all(2),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM*npoin2D_eta_all(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_crust_mantle(1)
+ accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(1,ipoin)
+ 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)
+ enddo
+
+ ioffset = npoin2D_eta_crust_mantle(1)
+ do ipoin = 1,npoin2D_eta_inner_core(1)
+ accel_inner_core(1,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(1,iboolleft_eta_inner_core(ipoin)) + &
+ buffer_received_faces_vector(1,ioffset + ipoin)
+ 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)
+ 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
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_eta_crust_mantle(1)
+
+ do ipoin = 1,npoin2D_eta_crust_mantle(1)
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin))
+ 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))
+ enddo
+
+ do ipoin = 1,npoin2D_eta_inner_core(1)
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolleft_eta_inner_core(ipoin))
+ 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))
+ 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*npoin2D_eta_all(1),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM*npoin2D_eta_all(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_crust_mantle(2)
+ accel_crust_mantle(1,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin)
+ 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)
+ enddo
+
+ ioffset = npoin2D_eta_crust_mantle(2)
+ do ipoin = 1,npoin2D_eta_inner_core(2)
+ accel_inner_core(1,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin)
+ 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)
+ 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*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(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
+ accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ipoin2D)
+ 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)
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ioffset + ipoin2D)
+ 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)
+ 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(1,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ 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))
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ buffer_send_faces_vector(1,ioffset + ipoin2D) = accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces))
+ 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))
+ enddo
+
+ call MPI_SEND(buffer_send_faces_vector,NDIM*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*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(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ipoin2D)
+ 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)
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ioffset + ipoin2D)
+ 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)
+ 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(1,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ 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))
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ buffer_send_faces_vector(1,ioffset + ipoin2D) = accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces))
+ 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))
+ enddo
+
+ call MPI_SEND(buffer_send_faces_vector,NDIM*npoin2D_chunks_all,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
+
+! 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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_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_chunkcorn_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ buffer_send_chunkcorn_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(3,ioffset + ipoin1D) = accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners))
+ enddo
+
+ call MPI_SEND(buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_vector(1,ipoin1D)
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(2,ipoin1D)
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(3,ipoin1D)
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(1,ioffset + ipoin1D)
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_vector(2,ioffset + ipoin1D)
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_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_chunkcorn_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ buffer_send_chunkcorn_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorn_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_chunkcorn_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_chunkcorn_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif
+
+ endif
+
+ enddo
+
+ end subroutine assemble_MPI_vector_block
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/auto_ner.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/auto_ner.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/auto_ner.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/auto_ner.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,586 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! 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
+ stop '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, CRUSTAL, &
+ HONOR_1D_SPHERICAL_MOHO, REFERENCE_1D_MODEL)
+
+ 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,CRUSTAL,HONOR_1D_SPHERICAL_MOHO
+ integer REFERENCE_1D_MODEL
+
+ ! local parameters
+ 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
+ double precision ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
+ double precision RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS
+
+ ! 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
+
+ ! gets model specific radii used to determine number of elements in radial direction
+ call get_model_parameters_radii(REFERENCE_1D_MODEL,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771, &
+ RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RMOHO_FICTITIOUS_IN_MESHER, &
+ R80_FICTITIOUS_IN_MESHER, &
+ RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
+ HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL)
+
+ radius(1) = R_EARTH ! Surface
+ radius(2) = RMOHO_FICTITIOUS_IN_MESHER ! Moho - 1st Mesh Doubling Interface
+ radius(3) = R80 ! 80
+ radius(4) = R220 ! 220
+ radius(5) = R400 ! 400
+ radius(6) = R600 ! 600
+ radius(7) = R670 ! 670
+ radius(8) = R771 ! 771
+ radius(9) = 4712000.0d0 ! 1650 - 2nd Mesh Doubling: Geochemical Layering; Kellogg et al. 1999, Science
+ radius(10) = RTOPDDOUBLEPRIME ! D''
+ radius(11) = RCMB ! CMB
+ radius(12) = 2511000.0d0 ! 3860 - 3rd Mesh Doubling Interface
+ radius(13) = 1371000.0d0 ! 5000 - 4th Mesh Doubling Interface
+ radius(14) = 982000.0d0 ! Top Central Cube
+
+ ! radii in km
+ radius(:) = radius(:) / 1000.0d0
+
+ 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 ), : )
+ 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/src/broadcast_compute_parameters.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/broadcast_compute_parameters.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/broadcast_compute_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/broadcast_compute_parameters.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,319 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine broadcast_compute_parameters(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ RMOHO_FICTITIOUS_IN_MESHER, &
+ MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
+ OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
+ LOCAL_PATH,MODEL, &
+ 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, &
+ ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
+ HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
+ ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ integer myrank
+
+ ! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ RMOHO_FICTITIOUS_IN_MESHER
+
+ logical MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT,&
+ OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) LOCAL_PATH,MODEL
+
+ ! parameters to be computed based upon parameters above read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
+
+ 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, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ratio_sampling_array,ner
+ 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
+
+ integer ratio_divide_central_cube
+
+ ! for the cut doublingbrick improvement
+ 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
+
+ ! mesh model parameters
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
+ HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
+ ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE
+
+ ! local parameters
+ double precision, dimension(31) :: bcast_double_precision
+ integer, dimension(39) :: bcast_integer
+ logical, dimension(35) :: bcast_logical
+ integer ier
+
+ ! master process prepares broadcasting arrays
+ if (myrank==0) then
+ ! count the total number of sources in the CMTSOLUTION file
+ call count_number_of_sources(NSOURCES)
+
+ ! funny way to pass parameters in arrays from master to all other processes
+ ! rather than single values one by one to reduce MPI communication calls:
+ ! sets up broadcasting array
+ 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, &
+ 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,NSOURCES,NOISE_TOMOGRAPHY/)
+
+ bcast_logical = (/TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,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, &
+ HONOR_1D_SPHERICAL_MOHO,MOVIE_COARSE, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE/)
+
+ 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,&
+ RMOHO_FICTITIOUS_IN_MESHER /)
+ endif
+
+ ! broadcasts the information read on the master to the nodes
+ call MPI_BCAST(bcast_integer,39,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(bcast_double_precision,31,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(bcast_logical,35,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ ! broadcasts non-single value parameters
+ call MPI_BCAST(LOCAL_PATH,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ 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,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)
+
+ ! non-master processes set their parameters
+ if (myrank /=0) then
+
+ ! please, be careful with ordering and counting here
+ ! integers
+ 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)
+ NPROC_XI = bcast_integer(16)
+ NPROC_ETA = bcast_integer(17)
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS = bcast_integer(18)
+ NTSTEP_BETWEEN_READ_ADJSRC = bcast_integer(19)
+ NSTEP = bcast_integer(20)
+ NSOURCES = bcast_integer(21)
+ NTSTEP_BETWEEN_FRAMES = bcast_integer(22)
+ NTSTEP_BETWEEN_OUTPUT_INFO = bcast_integer(23)
+ NUMBER_OF_RUNS = bcast_integer(24)
+ NUMBER_OF_THIS_RUN = bcast_integer(25)
+ NCHUNKS = bcast_integer(26)
+ SIMULATION_TYPE = bcast_integer(27)
+ REFERENCE_1D_MODEL = bcast_integer(28)
+ THREE_D_MODEL = bcast_integer(29)
+ NPROC = bcast_integer(30)
+ NPROCTOT = bcast_integer(31)
+ NEX_PER_PROC_XI = bcast_integer(32)
+ NEX_PER_PROC_ETA = bcast_integer(33)
+ ratio_divide_central_cube = bcast_integer(34)
+ MOVIE_VOLUME_TYPE = bcast_integer(35)
+ MOVIE_START = bcast_integer(36)
+ MOVIE_STOP = bcast_integer(37)
+ NSOURCES = bcast_integer(38)
+ NOISE_TOMOGRAPHY = bcast_integer(39)
+
+ ! logicals
+ 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)
+ HETEROGEN_3D_MANTLE = bcast_logical(10)
+ TOPOGRAPHY = bcast_logical(11)
+ OCEANS = bcast_logical(12)
+ MOVIE_SURFACE = bcast_logical(13)
+ MOVIE_VOLUME = 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)
+ CUT_SUPERBRICK_XI = bcast_logical(25)
+ CUT_SUPERBRICK_ETA = bcast_logical(26)
+ SAVE_ALL_SEISMOS_IN_ONE_FILE = bcast_logical(27)
+ HONOR_1D_SPHERICAL_MOHO = bcast_logical(28)
+ MOVIE_COARSE= bcast_logical(29)
+ OUTPUT_SEISMOS_ASCII_TEXT= bcast_logical(30)
+ OUTPUT_SEISMOS_SAC_ALPHANUM= bcast_logical(31)
+ OUTPUT_SEISMOS_SAC_BINARY= bcast_logical(32)
+ ROTATE_SEISMOGRAMS_RT= bcast_logical(33)
+ WRITE_SEISMOGRAMS_BY_MASTER= bcast_logical(34)
+ USE_BINARY_FOR_LARGE_FILE= bcast_logical(35)
+
+ ! double precisions
+ 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)
+ RMOHO_FICTITIOUS_IN_MESHER = bcast_double_precision(31)
+
+ endif
+
+ end subroutine broadcast_compute_parameters
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/calc_jacobian.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/calc_jacobian.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/calc_jacobian.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/calc_jacobian.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,501 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+!> Hejun
+! This subroutine recomputes the 3D jacobian for one element
+! based upon 125 GLL points
+! Hejun Zhu OCT16,2009
+
+! input: myrank,
+! xstore,ystore,zstore ----- input GLL point coordinate
+! xigll,yigll,zigll ----- gll points position
+! ispec,nspec ----- element number
+! ACTUALLY_STORE_ARRAYS ------ save array or not
+
+! output: xixstore,xiystore,xizstore,
+! etaxstore,etaystore,etazstore,
+! gammaxstore,gammaystore,gammazstore ------ parameters used to calculate jacobian
+
+
+ subroutine recalc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
+ ispec,nspec,ACTUALLY_STORE_ARRAYS,&
+ xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore)
+
+ implicit none
+
+ include "constants.h"
+
+ ! input parameter
+ integer::myrank,ispec,nspec
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+ double precision, dimension(NGLLX):: xigll
+ double precision, dimension(NGLLY):: yigll
+ double precision, dimension(NGLLZ):: zigll
+ logical::ACTUALLY_STORE_ARRAYS
+
+
+ ! output results
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ xixstore,xiystore,xizstore,&
+ etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore
+
+
+ ! local parameters for this subroutine
+ integer:: i,j,k,i1,j1,k1
+ double precision:: xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
+ double precision:: xi,eta,gamma
+ double precision,dimension(NGLLX):: hxir,hpxir
+ double precision,dimension(NGLLY):: hetar,hpetar
+ double precision,dimension(NGLLZ):: hgammar,hpgammar
+ double precision:: hlagrange,hlagrange_xi,hlagrange_eta,hlagrange_gamma
+ double precision:: jacobian
+ double precision:: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ double precision:: r,theta,phi
+
+
+ ! test parameters which can be deleted
+ double precision:: xmesh,ymesh,zmesh
+ double precision:: sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
+
+ ! first go over all 125 GLL points
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ xxi = 0.0
+ xeta = 0.0
+ xgamma = 0.0
+ yxi = 0.0
+ yeta = 0.0
+ ygamma = 0.0
+ zxi = 0.0
+ zeta = 0.0
+ zgamma = 0.0
+
+ xi = xigll(i)
+ eta = yigll(j)
+ gamma = zigll(k)
+
+ ! calculate lagrange polynomial and its derivative
+ call lagrange_any(xi,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta,NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma,NGLLZ,zigll,hgammar,hpgammar)
+
+ ! test parameters
+ sumshape = 0.0
+ sumdershapexi = 0.0
+ sumdershapeeta = 0.0
+ sumdershapegamma = 0.0
+ xmesh = 0.0
+ ymesh = 0.0
+ zmesh = 0.0
+
+
+ do k1 = 1,NGLLZ
+ do j1 = 1,NGLLY
+ do i1 = 1,NGLLX
+ hlagrange = hxir(i1)*hetar(j1)*hgammar(k1)
+ hlagrange_xi = hpxir(i1)*hetar(j1)*hgammar(k1)
+ hlagrange_eta = hxir(i1)*hpetar(j1)*hgammar(k1)
+ hlagrange_gamma = hxir(i1)*hetar(j1)*hpgammar(k1)
+
+
+ xxi = xxi + xstore(i1,j1,k1,ispec)*hlagrange_xi
+ xeta = xeta + xstore(i1,j1,k1,ispec)*hlagrange_eta
+ xgamma = xgamma + xstore(i1,j1,k1,ispec)*hlagrange_gamma
+
+ yxi = yxi + ystore(i1,j1,k1,ispec)*hlagrange_xi
+ yeta = yeta + ystore(i1,j1,k1,ispec)*hlagrange_eta
+ ygamma = ygamma + ystore(i1,j1,k1,ispec)*hlagrange_gamma
+
+ zxi = zxi + zstore(i1,j1,k1,ispec)*hlagrange_xi
+ zeta = zeta + zstore(i1,j1,k1,ispec)*hlagrange_eta
+ zgamma = zgamma + zstore(i1,j1,k1,ispec)*hlagrange_gamma
+
+ ! test the lagrange polynomial and its derivate
+ xmesh = xmesh + xstore(i1,j1,k1,ispec)*hlagrange
+ ymesh = ymesh + ystore(i1,j1,k1,ispec)*hlagrange
+ zmesh = zmesh + zstore(i1,j1,k1,ispec)*hlagrange
+ sumshape = sumshape + hlagrange
+ sumdershapexi = sumdershapexi + hlagrange_xi
+ sumdershapeeta = sumdershapeeta + hlagrange_eta
+ sumdershapegamma = sumdershapegamma + hlagrange_gamma
+
+ end do
+ end do
+ end do
+
+ ! Check the lagrange polynomial and its derivative
+ if (abs(xmesh - xstore(i,j,k,ispec)) > TINYVAL &
+ .or. abs(ymesh - ystore(i,j,k,ispec)) > TINYVAL &
+ .or. abs(zmesh - zstore(i,j,k,ispec)) > TINYVAL ) then
+ call exit_MPI(myrank,'new mesh are wrong in recalc_jacobian_gall3D.f90')
+ end if
+ if(abs(sumshape-one) > TINYVAL) then
+ call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapexi) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapeeta) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapegamma) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative gamma in recalc_jacobian_gll3D.f90')
+ end if
+
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+ xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
+
+ ! Check the jacobian
+ if(jacobian <= ZERO) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r,theta,phi)
+ print*,'r/lat/lon:',r*R_EARTH_KM,90.0-theta*180./PI,phi*180./PI
+ call exit_MPI(myrank,'3D Jacobian undefined in recalc_jacobian_gll3D.f90')
+ end if
+
+ ! 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
+
+
+ ! resave the derivatives and the jacobian
+ ! distinguish between single and double precision for reals
+ if (ACTUALLY_STORE_ARRAYS) then
+ 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)
+ 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
+ endif
+ end if
+ enddo
+ enddo
+ enddo
+
+ end subroutine recalc_jacobian_gll3D
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ ! Hejun Zhu used to recalculate 2D jacobian according to gll points rather
+ ! than control nodes
+ ! Hejun Zhu JAN08, 2010
+
+ ! input parameters: myrank,ispecb,
+ ! xelm2D,yelm2D,zelm2D,
+ ! xigll,yigll,NSPEC2DMAX_AB,NGLLA,NGLLB
+
+ ! output results: jacobian2D,normal
+ subroutine recalc_jacobian_gll2D(myrank,ispecb, &
+ xelm2D,yelm2D,zelm2D,xigll,yigll,&
+ jacobian2D,normal,NGLLA,NGLLB,NSPEC2DMAX_AB)
+
+ implicit none
+ include "constants.h"
+ ! input parameters
+ integer::myrank,ispecb,NSPEC2DMAX_AB,NGLLA,NGLLB
+ double precision,dimension(NGLLA,NGLLB)::xelm2D,yelm2D,zelm2D
+ double precision,dimension(NGLLA)::xigll
+ double precision,dimension(NGLLB)::yigll
+
+ ! output results
+ real(kind=CUSTOM_REAL),dimension(NGLLA,NGLLB,NSPEC2DMAX_AB)::jacobian2D
+ real(kind=CUSTOM_REAL),dimension(3,NGLLA,NGLLB,NSPEC2DMAX_AB)::normal
+
+
+ ! local parameters in this subroutine
+ integer::i,j,i1,j1
+ double precision::xxi,xeta,yxi,yeta,zxi,zeta,&
+ xi,eta,xmesh,ymesh,zmesh,hlagrange,hlagrange_xi,hlagrange_eta,&
+ sumshape,sumdershapexi,sumdershapeeta,unx,uny,unz,jacobian
+ double precision,dimension(NGLLA)::hxir,hpxir
+ double precision,dimension(NGLLB)::hetar,hpetar
+
+ do j = 1,NGLLB
+ do i = 1,NGLLA
+ xxi = 0.0
+ xeta = 0.0
+ yxi = 0.0
+ yeta = 0.0
+ zxi = 0.0
+ zeta = 0.0
+
+ xi=xigll(i)
+ eta = yigll(j)
+
+ call lagrange_any(xi,NGLLA,xigll,hxir,hpxir)
+ call lagrange_any(eta,NGLLB,yigll,hetar,hpetar)
+
+
+ xmesh = 0.0
+ ymesh = 0.0
+ zmesh = 0.0
+ sumshape = 0.0
+ sumdershapexi = 0.0
+ sumdershapeeta = 0.0
+ do j1 = 1,NGLLB
+ do i1 = 1,NGLLA
+ hlagrange = hxir(i1)*hetar(j1)
+ hlagrange_xi = hpxir(i1)*hetar(j1)
+ hlagrange_eta = hxir(i1)*hpetar(j1)
+
+ xxi = xxi + xelm2D(i1,j1)*hlagrange_xi
+ xeta = xeta + xelm2D(i1,j1)*hlagrange_eta
+
+ yxi = yxi + yelm2D(i1,j1)*hlagrange_xi
+ yeta = yeta + yelm2D(i1,j1)*hlagrange_eta
+
+ zxi = zxi + zelm2D(i1,j1)*hlagrange_xi
+ zeta = zeta + zelm2D(i1,j1)*hlagrange_eta
+
+ xmesh = xmesh + xelm2D(i1,j1)*hlagrange
+ ymesh = ymesh + yelm2D(i1,j1)*hlagrange
+ zmesh = zmesh + zelm2D(i1,j1)*hlagrange
+ sumshape = sumshape + hlagrange
+ sumdershapexi = sumdershapexi + hlagrange_xi
+ sumdershapeeta = sumdershapeeta + hlagrange_eta
+ end do
+ end do
+
+
+ ! Check the lagrange polynomial
+ if ( abs(xmesh - xelm2D(i,j)) > TINYVAL &
+ .or. abs(ymesh - yelm2D(i,j)) > TINYVAL &
+ .or. abs(zmesh - zelm2D(i,j)) > TINYVAL ) then
+ call exit_MPI(myrank,'new boundary mesh is wrong in recalc_jacobian_gll2D')
+ end if
+
+ if (abs(sumshape-one) > TINYVAL) then
+ call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll2D')
+ end if
+ if (abs(sumdershapexi) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll2D')
+ end if
+ if (abs(sumdershapeeta) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll2D')
+ end if
+
+ unx = yxi*zeta - yeta*zxi
+ uny = zxi*xeta - zeta*xxi
+ unz = xxi*yeta - xeta*yxi
+ jacobian = dsqrt(unx**2+uny**2+unz**2)
+ if (abs(jacobian) < TINYVAL ) call exit_MPI(myrank,'2D Jacobian undefined in recalc_jacobian_gll2D')
+
+ 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
+ end do
+ end do
+
+ end subroutine recalc_jacobian_gll2D
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+! deprecated...
+!
+! subroutine calc_jacobian(myrank,xixstore,xiystore,xizstore, &
+! etaxstore,etaystore,etazstore, &
+! gammaxstore,gammaystore,gammazstore, &
+! xstore,ystore,zstore, &
+! xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec,ACTUALLY_STORE_ARRAYS)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! integer ispec,nspec,myrank
+!
+! logical ACTUALLY_STORE_ARRAYS
+!
+! 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)
+!
+! real(kind=CUSTOM_REAL) xixstore(NGLLX,NGLLY,NGLLZ,nspec), &
+! xiystore(NGLLX,NGLLY,NGLLZ,nspec), &
+! xizstore(NGLLX,NGLLY,NGLLZ,nspec), &
+! etaxstore(NGLLX,NGLLY,NGLLZ,nspec), &
+! etaystore(NGLLX,NGLLY,NGLLZ,nspec), &
+! etazstore(NGLLX,NGLLY,NGLLZ,nspec), &
+! gammaxstore(NGLLX,NGLLY,NGLLZ,nspec), &
+! gammaystore(NGLLX,NGLLY,NGLLZ,nspec), &
+! gammazstore(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)
+!
+! 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) then
+! print*,'jacobian error:',myrank
+! print*,' point ijk:',i,j,k,ispec
+! print*,' xyz:',xmesh,ymesh,zmesh
+! call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,xxi,xeta,xgamma)
+! print*,' r/lat/lon:',xxi*R_EARTH_KM,90.0-xeta*180./PI,xgamma*180./PI
+! print*,' nodes:'
+! do ia=1,NGNOD
+! print*,xelm(ia),yelm(ia),zelm(ia)
+! enddo
+! print*
+! print*,'maybe check with CAP smoothing'
+! call exit_MPI(myrank,'3D Jacobian undefined')
+! endif
+!
+!! 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(ACTUALLY_STORE_ARRAYS) then
+! 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)
+! 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
+! endif
+! 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/src/calendar.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/calendar.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/calendar.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/calendar.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,729 @@
+
+ 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
+
+
+!----------------------------------------------------------------------------------------------
+! open-source subroutines below taken from ftp://ftp.met.fsu.edu/pub/ahlquist/calendar_software
+!----------------------------------------------------------------------------------------------
+
+ integer function idaywk(jdayno)
+
+! IDAYWK = compute the DAY of the WeeK given the Julian Day number,
+! version 1.0.
+
+ implicit none
+
+! Input variable
+ integer, intent(in) :: jdayno
+! jdayno = Julian Day number starting at noon of the day in question.
+
+! Output of the function:
+! idaywk = day of the week, where 0=Sunday, 1=Monday, ..., 6=Saturday.
+
+!----------
+! Compute the day of the week given the Julian Day number.
+! You can find the Julian Day number given (day,month,year)
+! using subroutine calndr below.
+! Example: For the first day of the Gregorian calendar,
+! Friday 15 October 1582, compute the Julian day number (option 3 of
+! subroutine calndr) and compute the day of the week.
+! call calndr (3, 15, 10, 1582, jdayno)
+! write(*,*) jdayno, idaywk(jdayno)
+! The numbers printed should be 2299161 and 5, where 5 refers to Friday.
+!
+! Copyright (C) 1999 Jon Ahlquist.
+! Issued under the second GNU General Public License.
+! See www.gnu.org for details.
+! 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.
+! If you find any errors, please notify:
+! Jon Ahlquist <ahlquist at met.fsu.edu>
+! Dept of Meteorology
+! Florida State University
+! Tallahassee, FL 32306-4520
+! 15 March 1999.
+!
+!-----
+
+! converted to Fortran90 by Dimitri Komatitsch,
+! University of Pau, France, January 2008.
+
+! jdSun is the Julian Day number starting at noon on any Sunday.
+! I arbitrarily chose the first Sunday after Julian Day 1,
+! which is Julian Day 6.
+ integer, parameter :: jdSun = 6
+
+ idaywk = mod(jdayno-jdSun,7)
+
+! If jdayno-jdSun < 0, then we are taking the modulus of a negative
+! number. Fortran's built-in mod function returns a negative value
+! when the argument is negative. In that case, we adjust the result
+! to a positive value.
+ if (idaywk < 0) idaywk = idaywk + 7
+
+ end function idaywk
+
+!
+!----
+!
+
+ subroutine calndr(iday,month,iyear,idayct)
+
+! CALNDR = CALeNDaR conversions, version 1.0
+
+ implicit none
+
+! specify the desired calendar conversion option.
+! in order to return the julian day number, compatible with function idaywk from above,
+! we choose option 3
+! (tested with dates: Feb, 23 2010 -> idaywk = Tue
+! Dec, 24 2009 -> idaywk = Thu
+! Oct, 15 1582 -> idaywk = Fri ...which all look o.k. )
+ integer, parameter :: ioptn = 3
+
+! Input/Output variables
+ integer, intent(inout) :: iday,month,iyear,idayct
+
+!----------
+!
+! Subroutine calndr() performs calendar calculations using either
+! the standard Gregorian calendar or the old Julian calendar.
+! This subroutine extends the definitions of these calendar systems
+! to any arbitrary year. The algorithms in this subroutine
+! will work with any date in the past or future,
+! but overflows will occur if the numbers are sufficiently large.
+! For a computer using a 32-bit integer, this routine can handle
+! any date between roughly 5.8 million BC and 5.8 million AD
+! without experiencing overflow during calculations.
+!
+! No external functions or subroutines are called.
+!
+!----------
+!
+! INPUT/OUTPUT ARGUMENTS FOR SUBROUTINE CALNDR()
+!
+! "ioptn" is the desired calendar conversion option explained below.
+! Positive option values use the standard modern Gregorian calendar.
+! Negative option values use the old Julian calendar which was the
+! standard in Europe from its institution by Julius Caesar in 45 BC
+! until at least 4 October 1582. The Gregorian and Julian calendars
+! are explained further below.
+!
+! (iday,month,iyear) is a calendar date where "iday" is the day of
+! the month, "month" is 1 for January, 2 for February, etc.,
+! and "iyear" is the year. If the year is 1968 AD, enter iyear=1968,
+! since iyear=68 would refer to 68 AD.
+! For BC years, iyear should be negative, so 45 BC would be iyear=-45.
+! By convention, there is no year 0 under the BC/AD year numbering
+! scheme. That is, years proceed as 2 BC, 1 BC, 1 AD, 2 AD, etc.,
+! without including 0. Subroutine calndr() will print an error message
+! and stop if you specify iyear=0.
+!
+! "idayct" is a day count. It is either the day number during the
+! specified year or the Julian Day number, depending on the value
+! of ioptn. By day number during the specified year, we mean
+! idayct=1 on 1 January, idayct=32 on 1 February, etc., to idayct=365
+! or 366 on 31 December, depending on whether the specified year
+! is a leap year.
+!
+! The values of input variables are not changed by this subroutine.
+!
+!
+! ALLOWABLE VALUES FOR "IOPTN" and the conversions they invoke.
+! Positive option values ( 1 to 5) use the standard Gregorian calendar.
+! Negative option values (-1 to -5) use the old Julian calendar.
+!
+! Absolute
+! value
+! of ioptn Input variable(s) Output variable(s)
+!
+! 1 iday,month,iyear idayct
+! Given a calendar date (iday,month,iyear), compute the day number
+! (idayct) during the year, where 1 January is day number 1 and
+! 31 December is day number 365 or 366, depending on whether it is
+! a leap year.
+!
+! 2 idayct,iyear iday,month
+! Given the day number of the year (idayct) and the year (iyear),
+! compute the day of the month (iday) and the month (month).
+!
+! 3 iday,month,iyear idayct
+! Given a calendar date (iday,month,iyear), compute the Julian Day
+! number (idayct) that starts at noon of the calendar date specified.
+!
+! 4 idayct iday,month,iyear
+! Given the Julian Day number (idayct) that starts at noon,
+! compute the corresponding calendar date (iday,month,iyear).
+!
+! 5 idayct iday,month,iyear
+! Given the Julian Day number (idayct) that starts at noon,
+! compute the corresponding day number for the year (iday)
+! and year (iyear). On return from calndr(), "month" will always
+! be set equal to 1 when ioptn=5.
+!
+! No inverse function is needed for ioptn=5 because it is
+! available through option 3. One simply calls calndr() with:
+! ioptn = 3,
+! iday = day number of the year instead of day of the month,
+! month = 1, and
+! iyear = whatever the desired year is.
+!
+!----------
+!
+! EXAMPLES
+! The first 6 examples are for the standard Gregorian calendar.
+! All the examples deal with 15 October 1582, which was the first day
+! of the Gregorian calendar. 15 October is the 288-th day of the year.
+! Julian Day number 2299161 began at noon on 15 October 1582.
+!
+! Find the day number during the year on 15 October 1582
+! ioptn = 1
+! call calndr (ioptn, 15, 10, 1582, idayct)
+! calndr() should return idayct=288
+!
+! Find the day of the month and month for day 288 in year 1582.
+! ioptn = 2
+! call calndr (ioptn, iday, month, 1582, 288)
+! calndr() should return iday=15 and month=10.
+!
+! Find the Julian Day number for 15 October 1582.
+! ioptn = 3
+! call calndr (ioptn, 15, 10, 1582, julian)
+! calndr() should return julian=2299161
+!
+! Find the Julian Day number for day 288 during 1582 AD.
+! When the input is day number of the year, one should specify month=1
+! ioptn = 3
+! call calndr (ioptn, 288, 1, 1582, julian)
+! calndr() should return dayct=2299161
+!
+! Find the date for Julian Day number 2299161.
+! ioptn = 4
+! call calndr (ioptn, iday, month, iyear, 2299161)
+! calndr() should return iday=15, month=10, and iyear=1582
+!
+! Find the day number during the year (iday) and year
+! for Julian Day number 2299161.
+! ioptn = 5
+! call calndr (ioptn, iday, month, iyear, 2299161)
+! calndr() should return iday=288, month=1, iyear=1582
+!
+! Given 15 October 1582 under the Gregorian calendar,
+! find the date (idayJ,imonthJ,iyearJ) under the Julian calendar.
+! To do this, we call calndr() twice, using the Julian Day number
+! as the intermediate value.
+! call calndr ( 3, 15, 10, 1582, julian)
+! call calndr (-4, idayJ, monthJ, iyearJ, julian)
+! The first call to calndr() should return julian=2299161, and
+! the second should return idayJ=5, monthJ=10, iyearJ=1582
+!
+!----------
+!
+! BASIC CALENDAR INFORMATION
+!
+! The Julian calendar was instituted by Julius Caesar in 45 BC.
+! Every fourth year is a leap year in which February has 29 days.
+! That is, the Julian calendar assumes that the year is exactly
+! 365.25 days long. Actually, the year is not quite this long.
+! The modern Gregorian calendar remedies this by omitting leap years
+! in years divisible by 100 except when the year is divisible by 400.
+! Thus, 1700, 1800, and 1900 are leap years under the Julian calendar
+! but not under the Gregorian calendar. The years 1600 and 2000 are
+! leap years under both the Julian and the Gregorian calendars.
+! Other years divisible by 4 are leap years under both calendars,
+! such as 1992, 1996, 2004, 2008, 2012, etc. For BC years, we recall
+! that year 0 was omitted, so 1 BC, 5 BC, 9 BC, 13 BC, etc., and 401 BC,
+! 801 BC, 1201 BC, etc., are leap years under both calendars, while
+! 101 BC, 201 BC, 301 BC, 501 BC, 601 BC, 701 BC, 901 BC, 1001 BC,
+! 1101 BC, etc., are leap years under the Julian calendar but not
+! the Gregorian calendar.
+!
+! The Gregorian calendar is named after Pope Gregory XIII. He declared
+! that the last day of the old Julian calendar would be Thursday,
+! 4 October 1582 and that the following day, Friday, would be reckoned
+! under the new calendar as 15 October 1582. The jump of 10 days was
+! included to make 21 March closer to the spring equinox.
+!
+! Only a few Catholic countries (Italy, Poland, Portugal, and Spain)
+! switched to the Gregorian calendar on the day after 4 October 1582.
+! It took other countries months to centuries to change to the
+! Gregorian calendar. For example, England's first day under the
+! Gregorian calendar was 14 September 1752. The same date applied to
+! the entire British empire, including America. Japan, Russia, and many
+! eastern European countries did not change to the Gregorian calendar
+! until the 20th century. The last country to change was Turkey,
+! which began using the Gregorian calendar on 1 January 1927.
+!
+! Therefore, between the years 1582 and 1926 AD, you must know
+! the country in which an event was dated to interpret the date
+! correctly. In Sweden, there was even a year (1712) when February
+! had 30 days. Consult a book on calendars for more details
+! about when various countries changed their calendars.
+!
+! DAY NUMBER DURING THE YEAR
+! The day number during the year is simply a counter equal to 1 on
+! 1 January, 32 on 1 February, etc., thorugh 365 or 366 on 31 December,
+! depending on whether the year is a leap year. Sometimes this is
+! called the Julian Day, but that term is better reserved for the
+! day counter explained below.
+!
+! JULIAN DAY NUMBER
+! The Julian Day numbering system was designed by Joseph Scaliger
+! in 1582 to remove ambiguity caused by varying calendar systems.
+! The name "Julian Day" was chosen to honor Scaliger's father,
+! Julius Caesar Scaliger (1484-1558), an Italian scholar and physician
+! who lived in France. Because Julian Day numbering was especially
+! designed for astronomers, Julian Days begin at noon so that the day
+! counter does not change in the middle of an astronmer's observing
+! period. Julian Day 0 began at noon on 1 January 4713 BC under the
+! Julian calendar. A modern reference point is that 23 May 1968
+! (Gregorian calendar) was Julian Day 2,440,000.
+!
+! JULIAN DAY NUMBER EXAMPLES
+!
+! The table below shows a few Julian Day numbers and their corresponding
+! dates, depending on which calendar is used. A negative 'iyear' refers
+! to BC (Before Christ).
+!
+! Julian Day under calendar:
+! iday month iyear Gregorian Julian
+! 24 11 -4714 0 -38
+! 1 1 -4713 38 0
+! 1 1 1 1721426 1721424
+! 4 10 1582 2299150 2299160
+! 15 10 1582 2299161 2299171
+! 1 3 1600 2305508 2305518
+! 23 5 1968 2440000 2440013
+! 5 7 1998 2451000 2451013
+! 1 3 2000 2451605 2451618
+! 1 1 2001 2451911 2451924
+!
+! From this table, we can see that the 10 day difference between the
+! two calendars in 1582 grew to 13 days by 1 March 1900, since 1900 was
+! a leap year under the Julian calendar but not under the Gregorian
+! calendar. The gap will widen to 14 days after 1 March 2100 for the
+! same reason.
+!
+!----------
+!
+! PORTABILITY
+!
+! This subroutine is written in standard FORTRAN 90.
+! It calls no external functions or subroutines and should run
+! without problem on any computer having a 32-bit word or longer.
+!
+!----------
+!
+! ALGORITHM
+!
+! The goal in coding calndr() was clear, clean code, not efficiency.
+! Calendar calculations usually take a trivial fraction of the time
+! in any program in which dates conversions are involved.
+! Data analysis usually takes the most time.
+!
+! Standard algorithms are followed in this subroutine. Internal to
+! this subroutine, we use a year counter "jyear" such that
+! jyear=iyear when iyear is positive
+! =iyear+1 when iyear is negative.
+! Thus, jyear does not experience a 1 year jump like iyear does
+! when going from BC to AD. Specifically, jyear=0 when iyear=-1,
+! i.e., when the year is 1 BC.
+!
+! For simplicity in dealing with February, inside this subroutine,
+! we let the year begin on 1 March so that the adjustable month,
+! February is the last month of the year.
+! It is clear that the calendar used to work this way because the
+! months September, October, November, and December refer to
+! 7, 8, 9, and 10. For consistency, jyear is incremented on 1 March
+! rather than on 1 January. Of course, everything is adjusted back to
+! standard practice of years beginning on 1 January before answers
+! are returned to the routine that calls calndr().
+!
+! Lastly, we use a trick to calculate the number of days from 1 March
+! until the end of the month that precedes the specified month.
+! That number of days is int(30.6001*(month+1))-122,
+! where 30.6001 is used to avoid the possibility of round-off and
+! truncation error. For example, if 30.6 were used instead,
+! 30.6*5 should be 153, but round-off error could make it 152.99999,
+! which would then truncated to 152, causing an error of 1 day.
+!
+! Algorithm reference:
+! Dershowitz, Nachum and Edward M. Reingold, 1990: Calendrical
+! Calculations. Software-Practice and Experience, vol. 20, number 9
+! (September 1990), pp. 899-928.
+!
+! Copyright (C) 1999 Jon Ahlquist.
+! Issued under the second GNU General Public License.
+! See www.gnu.org for details.
+! 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.
+! If you find any errors, please notify:
+! Jon Ahlquist <ahlquist at met.fsu.edu>
+! Dept of Meteorology
+! Florida State University
+! Tallahassee, FL 32306-4520
+! 15 March 1999.
+!
+!-----
+
+! converted to Fortran90 by Dimitri Komatitsch,
+! University of Pau, France, January 2008.
+
+! Declare internal variables.
+ integer jdref, jmonth, jyear, leap, n1yr, n4yr, n100yr, n400yr, ndays, ndy400, ndy100, nyrs, yr400, yrref
+!
+! Explanation of all internal variables.
+! jdref Julian Day on which 1 March begins in the reference year.
+! jmonth Month counter which equals month+1 if month .gt. 2
+! or month+13 if month .le. 2.
+! jyear Year index, jyear=iyear if iyear .gt. 0, jyear=iyear+1
+! if iyear .lt. 0. Thus, jyear does not skip year 0
+! like iyear does between BC and AD years.
+! leap =1 if the year is a leap year, =0 if not.
+! n1yr Number of complete individual years between iyear and
+! the reference year after all 4, 100,
+! and 400 year periods have been removed.
+! n4yr Number of complete 4 year cycles between iyear and
+! the reference year after all 100 and 400 year periods
+! have been removed.
+! n100yr Number of complete 100 year periods between iyear and
+! the reference year after all 400 year periods
+! have been removed.
+! n400yr Number of complete 400 year periods between iyear and
+! the reference year.
+! ndays Number of days since 1 March during iyear. (In intermediate
+! steps, it holds other day counts as well.)
+! ndy400 Number of days in 400 years. Under the Gregorian calendar,
+! this is 400*365 + 100 - 3 = 146097. Under the Julian
+! calendar, this is 400*365 + 100 = 146100.
+! ndy100 Number of days in 100 years, Under the Gregorian calendar,
+! this is 100*365 + 24 = 36524. Under the Julian calendar,
+! this is 100*365 + 25 = 36525.
+! nyrs Number of years from the beginning of yr400
+! to the beginning of jyear. (Used for option +/-3).
+! yr400 The largest multiple of 400 years that is .le. jyear.
+!
+!
+!----------------------------------------------------------------
+! Do preparation work.
+!
+! Look for out-of-range option values.
+ if ((ioptn == 0) .or. (abs(ioptn) >= 6)) then
+ write(*,*)'For calndr(), you specified ioptn = ', ioptn
+ write(*,*) 'Allowable values are 1 to 5 for the Gregorian calendar'
+ write(*,*) 'and -1 to -5 for the Julian calendar.'
+ stop
+ endif
+!
+! Options 1-3 have "iyear" as an input value.
+! Internally, we use variable "jyear" that does not have a jump
+! from -1 (for 1 BC) to +1 (for 1 AD).
+ if (abs(ioptn) <= 3) then
+ if (iyear > 0) then
+ jyear = iyear
+ elseif (iyear == 0) then
+ write(*,*) 'For calndr(), you specified the nonexistent year 0'
+ stop
+ else
+ jyear = iyear + 1
+ endif
+!
+! Set "leap" equal to 0 if "jyear" is not a leap year
+! and equal to 1 if it is a leap year.
+ leap = 0
+ if ((jyear/4)*4 == jyear) then
+ leap = 1
+ endif
+ if ((ioptn > 0) .and. &
+ ((jyear/100)*100 == jyear) .and. &
+ ((jyear/400)*400 /= jyear) ) then
+ leap = 0
+ endif
+ endif
+!
+! Options 3-5 involve Julian Day numbers, which need a reference year
+! and the Julian Days that began at noon on 1 March of the reference
+! year under the Gregorian and Julian calendars. Any year for which
+! "jyear" is divisible by 400 can be used as a reference year.
+! We chose 1600 AD as the reference year because it is the closest
+! multiple of 400 to the institution of the Gregorian calendar, making
+! it relatively easy to compute the Julian Day for 1 March 1600
+! given that, on 15 October 1582 under the Gregorian calendar,
+! the Julian Day was 2299161. Similarly, we need to do the same
+! calculation for the Julian calendar. We can compute this Julian
+! Day knwoing that on 4 October 1582 under the Julian calendar,
+! the Julian Day number was 2299160. The details of these calculations
+! is next.
+! From 15 October until 1 March, the number of days is the remainder
+! of October plus the days in November, December, January, and February:
+! 17+30+31+31+28 = 137, so 1 March 1583 under the Gregorian calendar
+! was Julian Day 2,299,298. Because of the 10 day jump ahead at the
+! switch from the Julian calendar to the Gregorian calendar, 1 March
+! 1583 under the Julian calendar was Julian Day 2,299,308. Making use
+! of the rules for the two calendar systems, 1 March 1600 was Julian
+! Day 2,299,298 + (1600-1583)*365 + 5 (due to leap years) =
+! 2,305,508 under the Gregorian calendar and day 2,305,518 under the
+! Julian calendar.
+! We also set the number of days in 400 years and 100 years.
+! For reference, 400 years is 146097 days under the Gregorian calendar
+! and 146100 days under the Julian calendar. 100 years is 36524 days
+! under the Gregorian calendar and 36525 days under the Julian calendar.
+ if (abs(ioptn) >= 3) then
+!
+! Julian calendar values.
+ yrref = 1600
+ jdref = 2305518
+! = Julian Day reference value for the day that begins
+! at noon on 1 March of the reference year "yrref".
+ ndy400 = 400*365 + 100
+ ndy100 = 100*365 + 25
+!
+! Adjust for Gregorian calendar values.
+ if (ioptn > 0) then
+ jdref = jdref - 10
+ ndy400 = ndy400 - 3
+ ndy100 = ndy100 - 1
+ endif
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -1 and +1:
+! Given a calendar date (iday,month,iyear), compute the day number
+! of the year (idayct), where 1 January is day number 1 and 31 December
+! is day number 365 or 366, depending on whether it is a leap year.
+ if (abs(ioptn) == 1) then
+!
+! Compute the day number during the year.
+ if (month <= 2) then
+ idayct = iday + (month-1)*31
+ else
+ idayct = iday + int(30.6001 * (month+1)) - 63 + leap
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -2 and +2:
+! Given the day number of the year (idayct) and the year (iyear),
+! compute the day of the month (iday) and the month (month).
+ elseif (abs(ioptn) == 2) then
+!
+ if (idayct < 60+leap) then
+ month = (idayct-1)/31
+ iday = idayct - month*31
+ month = month + 1
+ else
+ ndays = idayct - (60+leap)
+! = number of days past 1 March of the current year.
+ jmonth = (10*(ndays+31))/306 + 3
+! = month counter, =4 for March, =5 for April, etc.
+ iday = (ndays+123) - int(30.6001*jmonth)
+ month = jmonth - 1
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -3 and +3:
+! Given a calendar date (iday,month,iyear), compute the Julian Day
+! number (idayct) that starts at noon.
+ elseif (abs(ioptn) == 3) then
+!
+! Shift to a system where the year starts on 1 March, so January
+! and February belong to the preceding year.
+! Define jmonth=4 for March, =5 for April, ..., =15 for February.
+ if (month <= 2) then
+ jyear = jyear - 1
+ jmonth = month + 13
+ else
+ jmonth = month + 1
+ endif
+!
+! Find the closest multiple of 400 years that is .le. jyear.
+ yr400 = (jyear/400)*400
+! = multiple of 400 years at or less than jyear.
+ if (jyear < yr400) then
+ yr400 = yr400 - 400
+ endif
+!
+ n400yr = (yr400 - yrref)/400
+! = number of 400-year periods from yrref to yr400.
+ nyrs = jyear - yr400
+! = number of years from the beginning of yr400
+! to the beginning of jyear.
+!
+! Compute the Julian Day number.
+ idayct = iday + int(30.6001*jmonth) - 123 + 365*nyrs + nyrs/4 &
+ + jdref + n400yr*ndy400
+!
+! If we are using the Gregorian calendar, we must not count
+! every 100-th year as a leap year. nyrs is less than 400 years,
+! so we do not need to consider the leap year that would occur if
+! nyrs were divisible by 400, i.e., we do not add nyrs/400.
+ if (ioptn > 0) then
+ idayct = idayct - nyrs/100
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -5, -4, +4, and +5:
+! Given the Julian Day number (idayct) that starts at noon,
+! compute the corresponding calendar date (iday,month,iyear)
+! (abs(ioptn)=4) or day number during the year (abs(ioptn)=5).
+ else
+!
+! Create a new reference date which begins on the nearest
+! 400-year cycle less than or equal to the Julian Day for 1 March
+! in the year in which the given Julian Day number (idayct) occurs.
+ ndays = idayct - jdref
+ n400yr = ndays / ndy400
+! = integral number of 400-year periods separating
+! idayct and the reference date, jdref.
+ jdref = jdref + n400yr*ndy400
+ if (jdref > idayct) then
+ n400yr = n400yr - 1
+ jdref = jdref - ndy400
+ endif
+!
+ ndays = idayct - jdref
+! = number from the reference date to idayct.
+!
+ n100yr = min(ndays/ndy100, 3)
+! = number of complete 100-year periods
+! from the reference year to the current year.
+! The min() function is necessary to avoid n100yr=4
+! on 29 February of the last year in the 400-year cycle.
+!
+ ndays = ndays - n100yr*ndy100
+! = remainder after removing an integral number of
+! 100-year periods.
+!
+ n4yr = ndays / 1461
+! = number of complete 4-year periods in the current century.
+! 4 years consists of 4*365 + 1 = 1461 days.
+!
+ ndays = ndays - n4yr*1461
+! = remainder after removing an integral number
+! of 4-year periods.
+!
+ n1yr = min(ndays/365, 3)
+! = number of complete years since the last leap year.
+! The min() function is necessary to avoid n1yr=4
+! when the date is 29 February on a leap year,
+! in which case ndays=1460, and 1460/365 = 4.
+!
+ ndays = ndays - 365*n1yr
+! = number of days so far in the current year,
+! where ndays=0 on 1 March.
+!
+ iyear = n1yr + 4*n4yr + 100*n100yr + 400*n400yr + yrref
+! = year, as counted in the standard way,
+! but relative to 1 March.
+!
+! At this point, we need to separate ioptn=abs(4), which seeks a
+! calendar date, and ioptn=abs(5), which seeks the day number during
+! the year. First compute the calendar date if desired (abs(ioptn)=4).
+ if (abs(ioptn) == 4) then
+ jmonth = (10*(ndays+31))/306 + 3
+! = offset month counter. jmonth=4 for March, =13 for
+! December, =14 for January, =15 for February.
+ iday = (ndays+123) - int(30.6001*jmonth)
+! = day of the month, starting with 1 on the first day
+! of the month.
+!
+! Now adjust for the fact that the year actually begins
+! on 1 January.
+ if (jmonth <= 13) then
+ month = jmonth - 1
+ else
+ month = jmonth - 13
+ iyear = iyear + 1
+ endif
+!
+! This code handles abs(ioptn)=5, finding the day number during the year.
+ else
+! ioptn=5 always returns month=1, which we set now.
+ month = 1
+!
+! We need to determine whether this is a leap year.
+ leap = 0
+ if ((jyear/4)*4 == jyear) then
+ leap = 1
+ endif
+ if ((ioptn > 0) .and. &
+ ((jyear/100)*100 == jyear) .and. &
+ ((jyear/400)*400 /= jyear) ) then
+ leap = 0
+ endif
+!
+! Now find the day number "iday".
+! ndays is the number of days since the most recent 1 March,
+! so ndays=0 on 1 March.
+ if (ndays <=305) then
+ iday = ndays + 60 + leap
+ else
+ iday = ndays - 305
+ iyear = iyear + 1
+ endif
+ endif
+!
+! Adjust the year if it is .le. 0, and hence BC (Before Christ).
+ if (iyear <= 0) then
+ iyear = iyear - 1
+ endif
+!
+! End the code for the last option, ioptn.
+ endif
+
+ end subroutine calndr
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_1D.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_1D.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_1D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_1D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,582 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! code to check that all the internal MPI 1D buffers are okay
+! inside any given chunk, along both xi and eta
+! we compare the coordinates of the points in the buffers
+
+ program check_buffers_1D
+
+ implicit none
+
+ include "constants.h"
+
+ integer ithisproc,iotherproc
+ integer ipoin
+
+ double precision diff
+
+ integer npoin1D_mesher,npoin1D
+
+! for addressing of the slices
+ integer ichunk,iproc_xi,iproc_eta,iproc,icorners,iregion_code
+ integer iproc_read
+ integer, dimension(:,:,:), allocatable :: addressing
+
+! 1D addressing for copy of edges between slices
+! we add one to the size of the array for the final flag
+ integer, dimension(:), allocatable :: iboolleft,iboolright
+ double precision, dimension(:), allocatable :: xleft,yleft,zleft,xright,yright,zright
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, &
+ NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE,REFERENCE_1D_MODEL, &
+ THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ 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
+
+! this is for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ nglob
+
+! computed in read_compute_parameters
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! processor identification
+ character(len=150) prname,prname_other
+
+ integer :: NGLOB1D_RADIAL_MAX
+ 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(NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_SPEC_THIS
+ integer, dimension(NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_SPEC_OTHER
+! ************** PROGRAM STARTS HERE **************
+
+ print *
+ print *,'Check all MPI buffers along xi and eta inside each chunk'
+ print *
+
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ print *
+ print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
+ print *,'There are ',NCHUNKS,' chunks'
+ print *,'There are ',NPROC_XI,' slices along xi in each chunk'
+ print *,'There are ',NPROC_ETA,' slices along eta in each chunk'
+ print *
+
+! dynamic memory allocation for arrays
+ allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1))
+
+! open file with global slice number addressing
+ print *,'reading slice addressing'
+ open(unit=34,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read')
+ do iproc = 0,NPROCTOT-1
+ read(34,*) iproc_read,ichunk,iproc_xi,iproc_eta
+ if(iproc_read /= iproc) stop 'incorrect slice number read'
+ addressing(ichunk,iproc_xi,iproc_eta) = iproc
+ enddo
+ close(34)
+
+! loop over all the regions of the mesh
+ do iregion_code = 1,MAX_NUM_REGIONS
+
+ print *
+ print *,' ********* checking region ',iregion_code,' *********'
+ print *
+
+ NGLOB1D_RADIAL_CORNER(iregion_code,:) = NGLOB1D_RADIAL(iregion_code)
+ NGLOB1D_RADIAL_MAX = NGLOB1D_RADIAL(iregion_code)
+ if (iregion_code == IREGION_OUTER_CORE .and. (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
+ NGLOB1D_RADIAL_MAX = NGLOB1D_RADIAL_MAX + maxval(DIFF_NSPEC1D_RADIAL(:,:))*(NGLLZ-1)
+ endif
+
+! dynamic memory allocation for arrays
+ allocate(iboolleft(NGLOB1D_RADIAL_MAX+1))
+ allocate(iboolright(NGLOB1D_RADIAL_MAX+1))
+ allocate(xleft(NGLOB1D_RADIAL_MAX+1))
+ allocate(yleft(NGLOB1D_RADIAL_MAX+1))
+ allocate(zleft(NGLOB1D_RADIAL_MAX+1))
+ allocate(xright(NGLOB1D_RADIAL_MAX+1))
+ allocate(yright(NGLOB1D_RADIAL_MAX+1))
+ allocate(zright(NGLOB1D_RADIAL_MAX+1))
+
+! ********************************************************
+! *************** check along xi
+! ********************************************************
+
+! loop for both corners for 1D buffers
+ do icorners=1,2
+
+ print *
+ print *,'Checking for xi in set of corners # ',icorners
+ print *
+
+! loop on the chunks
+ do ichunk = 1,NCHUNKS
+
+ print *
+ print *,'Checking xi in chunk ',ichunk
+ print *
+
+! double loop on NPROC_XI and NPROC_ETA
+ do iproc_eta=0,NPROC_ETA-1
+
+ print *,'checking row ',iproc_eta
+
+ do iproc_xi=0,NPROC_XI-2
+
+ print *,'checking slice ixi = ',iproc_xi,' in that row'
+
+ ithisproc = addressing(ichunk,iproc_xi,iproc_eta)
+ iotherproc = addressing(ichunk,iproc_xi+1,iproc_eta)
+
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_CORNER(iregion_code,:)
+ if (iregion_code==IREGION_OUTER_CORE) then
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_xi,2) == 0) then
+ if (mod(iproc_eta,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ else
+ if (mod(iproc_eta,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (mod(iproc_xi,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_eta,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ endif
+ endif
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_CORNER(iregion_code,:)
+ if (iregion_code==IREGION_OUTER_CORE) then
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_xi+1,2) == 0) then
+ if (mod(iproc_eta,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ else
+ if (mod(iproc_eta,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (mod(iproc_xi+1,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_eta,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ endif
+ endif
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,ithisproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+ call create_serial_name_database(prname_other,iotherproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+
+! read 1D addressing buffers for copy between slices along xi with MPI
+
+ if(icorners == 1) then
+! read ibool1D_rightxi_lefteta of this slice
+ write(*,*) 'reading MPI 1D buffer ibool1D_rightxi_lefteta slice ',ithisproc
+ open(unit=34,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='old',action='read')
+ else if(icorners == 2) then
+! read ibool1D_rightxi_righteta of this slice
+ write(*,*) 'reading MPI 1D buffer ibool1D_rightxi_righteta slice ',ithisproc
+ open(unit=34,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='old',action='read')
+ else
+ stop 'incorrect corner number'
+ endif
+
+ npoin1D = 1
+ 360 continue
+ read(34,*) iboolright(npoin1D),xright(npoin1D),yright(npoin1D),zright(npoin1D)
+ if(iboolright(npoin1D) > 0) then
+ npoin1D = npoin1D + 1
+ goto 360
+ endif
+ npoin1D = npoin1D - 1
+ write(*,*) 'found ',npoin1D,' points in iboolright slice ',ithisproc
+ read(34,*) npoin1D_mesher
+ if(icorners == 1) then
+ if(npoin1D /= NGLOB1D_RADIAL_SPEC_THIS(2)) stop 'incorrect iboolright read'
+ else
+ if(npoin1D /= NGLOB1D_RADIAL_SPEC_THIS(3)) stop 'incorrect iboolright read'
+ endif
+ close(34)
+
+ if(icorners == 1) then
+! read ibool1D_leftxi_lefteta of other slice
+ write(*,*) 'reading MPI 1D buffer ibool1D_leftxi_lefteta slice ',iotherproc
+ open(unit=34,file=prname_other(1:len_trim(prname_other))//'ibool1D_leftxi_lefteta.txt',status='old',action='read')
+ else if(icorners == 2) then
+! read ibool1D_leftxi_righteta of other slice
+ write(*,*) 'reading MPI 1D buffer ibool1D_leftxi_righteta slice ',iotherproc
+ open(unit=34,file=prname_other(1:len_trim(prname_other))//'ibool1D_leftxi_righteta.txt',status='old',action='read')
+ else
+ stop 'incorrect corner number'
+ endif
+
+ npoin1D = 1
+ 350 continue
+ read(34,*) iboolleft(npoin1D),xleft(npoin1D),yleft(npoin1D),zleft(npoin1D)
+ if(iboolleft(npoin1D) > 0) then
+ npoin1D = npoin1D + 1
+ goto 350
+ endif
+ npoin1D = npoin1D - 1
+ write(*,*) 'found ',npoin1D,' points in iboolleft slice ',iotherproc
+ read(34,*) npoin1D_mesher
+ if(icorners == 1) then
+ if(npoin1D /= NGLOB1D_RADIAL_SPEC_OTHER(1)) stop 'incorrect iboolleft read'
+ else
+ if(npoin1D /= NGLOB1D_RADIAL_SPEC_OTHER(4)) stop 'incorrect iboolleft read'
+ endif
+ close(34)
+
+! check the coordinates of all the points in the buffer
+! to see if it is correctly sorted
+ do ipoin = 1,npoin1D
+ diff = dmax1(dabs(xleft(ipoin)-xright(ipoin)), &
+ dabs(yleft(ipoin)-yright(ipoin)),dabs(zleft(ipoin)-zright(ipoin)))
+ if(diff > 0.0000001d0) then
+ print *,'different: ',ipoin,iboolleft(ipoin),iboolright(ipoin),diff
+ stop 'error: different'
+ endif
+ enddo
+
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+
+! ********************************************************
+! *************** check along eta
+! ********************************************************
+
+! added loop for both corners for 1D buffers
+ do icorners=1,2
+
+ print *
+ print *,'Checking for eta in set of corners # ',icorners
+ print *
+
+! loop on the chunks
+ do ichunk = 1,NCHUNKS
+
+ print *
+ print *,'Checking eta in chunk ',ichunk
+ print *
+
+! double loop on NPROC_XI and NPROC_ETA
+ do iproc_xi=0,NPROC_XI-1
+
+ print *,'checking row ',iproc_xi
+
+ do iproc_eta=0,NPROC_ETA-2
+
+ print *,'checking slice ieta = ',iproc_eta,' in that row'
+
+ ithisproc = addressing(ichunk,iproc_xi,iproc_eta)
+ iotherproc = addressing(ichunk,iproc_xi,iproc_eta+1)
+
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_CORNER(iregion_code,:)
+ if (iregion_code==IREGION_OUTER_CORE) then
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_xi,2) == 0) then
+ if (mod(iproc_eta,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ else
+ if (mod(iproc_eta,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (mod(iproc_xi,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_eta,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_THIS(:) = NGLOB1D_RADIAL_SPEC_THIS(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ endif
+ endif
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_CORNER(iregion_code,:)
+ if (iregion_code==IREGION_OUTER_CORE) then
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_xi,2) == 0) then
+ if (mod(iproc_eta+1,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ else
+ if (mod(iproc_eta+1,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (mod(iproc_xi,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_eta+1,2) == 0) then
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NGLOB1D_RADIAL_SPEC_OTHER(:) = NGLOB1D_RADIAL_SPEC_OTHER(:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ endif
+ endif
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,ithisproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+ call create_serial_name_database(prname_other,iotherproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+
+! read 1D addressing buffers for copy between slices along xi with MPI
+
+ if(icorners == 1) then
+! read ibool1D_leftxi_righteta of this slice
+ write(*,*) 'reading MPI 1D buffer ibool1D_leftxi_righteta slice ',ithisproc
+ open(unit=34,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='old',action='read')
+ else if(icorners == 2) then
+! read ibool1D_rightxi_righteta of this slice
+ write(*,*) 'reading MPI 1D buffer ibool1D_rightxi_righteta slice ',ithisproc
+ open(unit=34,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='old',action='read')
+ else
+ stop 'incorrect corner number'
+ endif
+
+ npoin1D = 1
+ 460 continue
+ read(34,*) iboolright(npoin1D),xright(npoin1D),yright(npoin1D),zright(npoin1D)
+ if(iboolright(npoin1D) > 0) then
+ npoin1D = npoin1D + 1
+ goto 460
+ endif
+ npoin1D = npoin1D - 1
+ write(*,*) 'found ',npoin1D,' points in iboolright slice ',ithisproc
+ read(34,*) npoin1D_mesher
+
+ if(icorners == 1) then
+ if(npoin1D /= NGLOB1D_RADIAL_SPEC_THIS(4)) stop 'incorrect iboolright read'
+ else
+ if(npoin1D /= NGLOB1D_RADIAL_SPEC_THIS(3)) stop 'incorrect iboolright read'
+ endif
+ close(34)
+
+ if(icorners == 1) then
+! read ibool1D_leftxi_lefteta of other slice
+ write(*,*) 'reading MPI 1D buffer ibool1D_leftxi_lefteta slice ',iotherproc
+ open(unit=34,file=prname_other(1:len_trim(prname_other))//'ibool1D_leftxi_lefteta.txt',status='old',action='read')
+ else if(icorners == 2) then
+! read ibool1D_rightxi_lefteta of other slice
+ write(*,*) 'reading MPI 1D buffer ibool1D_rightxi_lefteta slice ',iotherproc
+ open(unit=34,file=prname_other(1:len_trim(prname_other))//'ibool1D_rightxi_lefteta.txt',status='old',action='read')
+ else
+ stop 'incorrect corner number'
+ endif
+
+ npoin1D = 1
+ 450 continue
+ read(34,*) iboolleft(npoin1D),xleft(npoin1D),yleft(npoin1D),zleft(npoin1D)
+ if(iboolleft(npoin1D) > 0) then
+ npoin1D = npoin1D + 1
+ goto 450
+ endif
+ npoin1D = npoin1D - 1
+ write(*,*) 'found ',npoin1D,' points in iboolleft slice ',iotherproc
+ read(34,*) npoin1D_mesher
+
+ if(icorners == 1) then
+ if(npoin1D /= NGLOB1D_RADIAL_SPEC_OTHER(1)) stop 'incorrect iboolleft read'
+ else
+ if(npoin1D /= NGLOB1D_RADIAL_SPEC_OTHER(2)) stop 'incorrect iboolleft read'
+ endif
+ close(34)
+
+! check the coordinates of all the points in the buffer
+! to see if it is correctly sorted
+ do ipoin = 1,npoin1D
+ diff = dmax1(dabs(xleft(ipoin)-xright(ipoin)), &
+ dabs(yleft(ipoin)-yright(ipoin)),dabs(zleft(ipoin)-zright(ipoin)))
+ if(diff > 0.0000001d0) then
+ print *,'different: ',ipoin,iboolleft(ipoin),iboolright(ipoin),diff
+ stop 'error: different'
+ endif
+ enddo
+
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+! deallocate arrays
+ deallocate(iboolleft)
+ deallocate(iboolright)
+ deallocate(xleft)
+ deallocate(yleft)
+ deallocate(zleft)
+ deallocate(xright)
+ deallocate(yright)
+ deallocate(zright)
+
+ enddo
+
+ print *
+ print *,'done'
+ print *
+
+ end program check_buffers_1D
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_2D.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_2D.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_2D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_2D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,404 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! code to check that all the internal MPI buffers are okay
+! inside any given chunk, along both xi and eta
+! we compare the coordinates of the points in the buffers
+
+ program check_buffers_2D
+
+ implicit none
+
+ include "constants.h"
+
+ integer ithisproc,iotherproc
+
+ integer ipoin
+
+ integer npoin2d_xi_save,npoin2d_xi_mesher,npoin2d_xi
+ integer npoin2d_eta_save,npoin2d_eta_mesher,npoin2d_eta
+
+! for addressing of the slices
+ integer ichunk,iproc_xi,iproc_eta,iproc
+ integer iproc_read,iregion_code
+ integer, dimension(:,:,:), allocatable :: addressing
+
+ double precision diff
+
+! 2-D addressing and buffers for summation between slices
+ integer, dimension(:), allocatable :: iboolleft_xi,iboolright_xi, &
+ iboolleft_eta,iboolright_eta
+
+! coordinates of the points to compare
+ double precision, dimension(:), allocatable :: xleft_xi,yleft_xi,zleft_xi, &
+ xright_xi,yright_xi,zright_xi,xleft_eta,yleft_eta,zleft_eta, &
+ xright_eta,yright_eta,zright_eta
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ 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
+
+! 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
+
+ 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
+
+! now this is 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
+
+! processor identification
+ character(len=150) prname,prname_other
+
+ 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 **************
+
+ print *
+ print *,'Check all MPI buffers along xi and eta inside each chunk'
+ print *
+
+! read the parameter file and compute additional parameters
+
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
+
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ print *
+ print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
+ print *,'There are ',NCHUNKS,' chunks'
+ print *,'There are ',NPROC_XI,' slices along xi in each chunk'
+ print *,'There are ',NPROC_ETA,' slices along eta in each chunk'
+ print *
+
+! dynamic memory allocation for arrays
+ allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1))
+
+! open file with global slice number addressing
+ print *,'reading slice addressing'
+ open(unit=34,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read')
+ do iproc = 0,NPROCTOT-1
+ read(34,*) iproc_read,ichunk,iproc_xi,iproc_eta
+ if(iproc_read /= iproc) stop 'incorrect slice number read'
+ addressing(ichunk,iproc_xi,iproc_eta) = iproc
+ enddo
+ close(34)
+
+! loop over all the regions of the mesh
+ do iregion_code = 1,MAX_NUM_REGIONS
+
+ print *
+ print *,' ********* checking region ',iregion_code,' *********'
+ print *
+
+! dynamic memory allocation for arrays
+ allocate(iboolleft_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
+ allocate(iboolright_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
+ allocate(iboolleft_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
+ allocate(iboolright_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
+ allocate(xleft_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
+ allocate(yleft_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
+ allocate(zleft_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
+ allocate(xright_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
+ allocate(yright_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
+ allocate(zright_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)))
+ allocate(xleft_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
+ allocate(yleft_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
+ allocate(zleft_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
+ allocate(xright_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
+ allocate(yright_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
+ allocate(zright_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)))
+
+! loop on the chunks
+ do ichunk = 1,NCHUNKS
+
+ print *
+ print *,'Checking xi in chunk ',ichunk
+ print *
+
+! double loop on NPROC_XI and NPROC_ETA
+ do iproc_eta=0,NPROC_ETA-1
+
+ print *,'checking row ',iproc_eta
+
+ do iproc_xi=0,NPROC_XI-2
+
+ print *,'checking slice ixi = ',iproc_xi,' in that row'
+
+ ithisproc = addressing(ichunk,iproc_xi,iproc_eta)
+ iotherproc = addressing(ichunk,iproc_xi+1,iproc_eta)
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,ithisproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+ call create_serial_name_database(prname_other,iotherproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+
+! read 2-D addressing for summation between slices along xi with MPI
+
+! read iboolright_xi of this slice
+ write(*,*) 'reading MPI buffer iboolright_xi slice ',ithisproc
+ open(unit=34,file=prname(1:len_trim(prname))//'iboolright_xi.txt',status='old',action='read')
+ npoin2D_xi = 1
+ 360 continue
+ read(34,*) iboolright_xi(npoin2D_xi), &
+ xright_xi(npoin2D_xi),yright_xi(npoin2D_xi),zright_xi(npoin2D_xi)
+ if(iboolright_xi(npoin2D_xi) > 0) then
+ npoin2D_xi = npoin2D_xi + 1
+ goto 360
+ endif
+ npoin2D_xi = npoin2D_xi - 1
+ write(*,*) 'found ',npoin2D_xi,' points in iboolright_xi slice ',ithisproc
+ read(34,*) npoin2D_xi_mesher
+ if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX(iregion_code) .or. npoin2D_xi /= npoin2D_xi_mesher) then
+ stop 'incorrect iboolright_xi read'
+ endif
+ close(34)
+
+! save to compare to other side
+ npoin2D_xi_save = npoin2D_xi
+
+! read iboolleft_xi of other slice
+ write(*,*) 'reading MPI buffer iboolleft_xi slice ',iotherproc
+ open(unit=34,file=prname_other(1:len_trim(prname_other))//'iboolleft_xi.txt',status='old',action='read')
+ npoin2D_xi = 1
+ 350 continue
+ read(34,*) iboolleft_xi(npoin2D_xi), &
+ xleft_xi(npoin2D_xi),yleft_xi(npoin2D_xi),zleft_xi(npoin2D_xi)
+ if(iboolleft_xi(npoin2D_xi) > 0) then
+ npoin2D_xi = npoin2D_xi + 1
+ goto 350
+ endif
+ npoin2D_xi = npoin2D_xi - 1
+ write(*,*) 'found ',npoin2D_xi,' points in iboolleft_xi slice ',iotherproc
+ read(34,*) npoin2D_xi_mesher
+ if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX(iregion_code) .or. npoin2D_xi /= npoin2D_xi_mesher) then
+ stop 'incorrect iboolleft_xi read'
+ endif
+ close(34)
+
+ if(npoin2D_xi_save == npoin2D_xi) then
+ print *,'okay, same size for both buffers'
+ else
+ stop 'wrong buffer size'
+ endif
+
+! check the coordinates of all the points in the buffer
+! to see if it is correctly sorted
+ do ipoin = 1,npoin2D_xi
+ diff = dmax1(dabs(xleft_xi(ipoin)-xright_xi(ipoin)), &
+ dabs(yleft_xi(ipoin)-yright_xi(ipoin)),dabs(zleft_xi(ipoin)-zright_xi(ipoin)))
+ if(diff > 0.0000001d0) print *,'different: ',ipoin,iboolleft_xi(ipoin),iboolright_xi(ipoin),diff
+ enddo
+
+ enddo
+ enddo
+ enddo
+
+
+! loop on the chunks
+ do ichunk = 1,NCHUNKS
+
+ print *
+ print *,'Checking eta in chunk ',ichunk
+ print *
+
+! double loop on NPROC_XI and NPROC_ETA
+ do iproc_xi=0,NPROC_XI-1
+
+ print *,'checking row ',iproc_xi
+
+ do iproc_eta=0,NPROC_ETA-2
+
+ print *,'checking slice ieta = ',iproc_eta,' in that row'
+
+ ithisproc = addressing(ichunk,iproc_xi,iproc_eta)
+ iotherproc = addressing(ichunk,iproc_xi,iproc_eta+1)
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,ithisproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+ call create_serial_name_database(prname_other,iotherproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+
+! read 2-D addressing for summation between slices along xi with MPI
+
+! read iboolright_eta of this slice
+ write(*,*) 'reading MPI buffer iboolright_eta slice ',ithisproc
+ open(unit=34,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='old',action='read')
+ npoin2D_eta = 1
+ 460 continue
+ read(34,*) iboolright_eta(npoin2D_eta), &
+ xright_eta(npoin2D_eta),yright_eta(npoin2D_eta),zright_eta(npoin2D_eta)
+ if(iboolright_eta(npoin2D_eta) > 0) then
+ npoin2D_eta = npoin2D_eta + 1
+ goto 460
+ endif
+ npoin2D_eta = npoin2D_eta - 1
+ write(*,*) 'found ',npoin2D_eta,' points in iboolright_eta slice ',ithisproc
+ read(34,*) npoin2D_eta_mesher
+ if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX(iregion_code) .or. npoin2D_eta /= npoin2D_eta_mesher) then
+ stop 'incorrect iboolright_eta read'
+ endif
+ close(34)
+
+! save to compare to other side
+ npoin2D_eta_save = npoin2D_eta
+
+! read iboolleft_eta of other slice
+ write(*,*) 'reading MPI buffer iboolleft_eta slice ',iotherproc
+ open(unit=34,file=prname_other(1:len_trim(prname_other))//'iboolleft_eta.txt',status='old',action='read')
+ npoin2D_eta = 1
+ 450 continue
+ read(34,*) iboolleft_eta(npoin2D_eta), &
+ xleft_eta(npoin2D_eta),yleft_eta(npoin2D_eta),zleft_eta(npoin2D_eta)
+ if(iboolleft_eta(npoin2D_eta) > 0) then
+ npoin2D_eta = npoin2D_eta + 1
+ goto 450
+ endif
+ npoin2D_eta = npoin2D_eta - 1
+ write(*,*) 'found ',npoin2D_eta,' points in iboolleft_eta slice ',iotherproc
+ read(34,*) npoin2D_eta_mesher
+ if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX(iregion_code) .or. npoin2D_eta /= npoin2D_eta_mesher) then
+ stop 'incorrect iboolleft_eta read'
+ endif
+ close(34)
+
+ if(npoin2D_eta_save == npoin2D_eta) then
+ print *,'okay, same size for both buffers'
+ else
+ stop 'wrong buffer size'
+ endif
+
+! check the coordinates of all the points in the buffer
+! to see if it is correctly sorted
+ do ipoin = 1,npoin2D_eta
+ diff = dmax1(dabs(xleft_eta(ipoin)-xright_eta(ipoin)), &
+ dabs(yleft_eta(ipoin)-yright_eta(ipoin)),dabs(zleft_eta(ipoin)-zright_eta(ipoin)))
+ if(diff > 0.0000001d0) print *,'different: ',ipoin,iboolleft_eta(ipoin),iboolright_eta(ipoin),diff
+ enddo
+
+ enddo
+ enddo
+ enddo
+
+! deallocate arrays
+ deallocate(iboolleft_xi)
+ deallocate(iboolright_xi)
+ deallocate(iboolleft_eta)
+ deallocate(iboolright_eta)
+ deallocate(xleft_xi)
+ deallocate(yleft_xi)
+ deallocate(zleft_xi)
+ deallocate(xright_xi)
+ deallocate(yright_xi)
+ deallocate(zright_xi)
+ deallocate(xleft_eta)
+ deallocate(yleft_eta)
+ deallocate(zleft_eta)
+ deallocate(xright_eta)
+ deallocate(yright_eta)
+ deallocate(zright_eta)
+
+ enddo
+
+ print *
+ print *,'done'
+ print *
+
+ end program check_buffers_2D
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_corners_chunks.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_corners_chunks.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_corners_chunks.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_corners_chunks.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,293 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! code to check that all the 1D buffers between chunk corners are okay
+
+ program check_buffers_corners_chunks
+
+ implicit none
+
+ include "constants.h"
+
+ integer imsg
+ integer ipoin1D
+ integer iboolmaster,iboolworker1,iboolworker2
+ integer npoin1D_master,npoin1D_worker1,npoin1D_worker2
+ integer iregion_code,iproc
+
+! number of corners between chunks
+ integer NCORNERSCHUNKS
+
+ double precision xmaster,ymaster,zmaster
+ double precision xworker1,yworker1,zworker1
+ double precision xworker2,yworker2,zworker2
+ double precision diff1,diff2
+
+! communication pattern for corners between chunks
+ integer, dimension(:), allocatable :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ 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
+
+! this is 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
+
+ character(len=150) filename,prname
+
+! computed in read_compute_parameters
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+! ************** PROGRAM STARTS HERE **************
+
+ print *
+ print *,'Check all MPI buffers between chunk corners'
+ print *
+
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
+
+ print *
+ print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
+ print *,'There are ',NCHUNKS,' chunks'
+ print *,'There are ',NPROC_XI,' slices along xi in each chunk'
+ print *,'There are ',NPROC_ETA,' slices along eta in each chunk'
+ print *
+
+! number of corners shared between chunks
+ if(NCHUNKS == 1 .or. NCHUNKS == 2 .or. NCHUNKS == 3) then
+ NCORNERSCHUNKS = 1
+ else if(NCHUNKS == 6) then
+ NCORNERSCHUNKS = 8
+ else
+ stop 'number of chunks must be either 1, 2, 3 or 6'
+ endif
+
+ if(NCHUNKS == 1) stop 'only one chunk, nothing to check'
+
+ print *,'There are ',NCORNERSCHUNKS,' messages to assemble all the corners'
+ print *
+
+! allocate array for messages for corners
+ allocate(iproc_master_corners(NCORNERSCHUNKS))
+ allocate(iproc_worker1_corners(NCORNERSCHUNKS))
+ allocate(iproc_worker2_corners(NCORNERSCHUNKS))
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! 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
+ 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) &
+ stop 'incorrect chunk corner numbering'
+ enddo
+ close(IIN)
+
+! loop over all the regions of the mesh
+ do iregion_code = 1,MAX_NUM_REGIONS
+
+ print *
+ print *,' ********* checking region ',iregion_code,' *********'
+ print *
+
+! loop on all the messages between corners
+ do imsg = 1,NCORNERSCHUNKS
+
+ print *
+ print *,'Checking message ',imsg,' out of ',NCORNERSCHUNKS
+
+! read 1-D buffers for the corners
+
+! master
+ write(filename,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
+ iproc = iproc_master_corners(imsg)
+ call create_serial_name_database(prname,iproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+ open(unit=34,file=prname(1:len_trim(prname))//filename,status='old',action='read')
+
+! first worker
+ write(filename,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
+ iproc = iproc_worker1_corners(imsg)
+ call create_serial_name_database(prname,iproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+ open(unit=35,file=prname(1:len_trim(prname))//filename,status='old',action='read')
+
+! second worker
+! if only two chunks then there is no second worker
+ if(NCHUNKS /= 2) then
+ write(filename,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
+ iproc = iproc_worker2_corners(imsg)
+ call create_serial_name_database(prname,iproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+ open(unit=36,file=prname(1:len_trim(prname))//filename,status='old',action='read')
+ endif
+
+ write(*,*) 'reading MPI 1D buffers for 3 procs corner'
+
+ read(34,*) npoin1D_master
+ read(35,*) npoin1D_worker1
+! if only two chunks then there is no second worker
+ if(NCHUNKS /= 2) then
+ read(36,*) npoin1D_worker2
+ else
+ npoin1D_worker2 = npoin1D_worker1
+ endif
+
+ if(npoin1D_master /= NGLOB1D_RADIAL(iregion_code) .or. &
+ npoin1D_worker1 /= NGLOB1D_RADIAL(iregion_code) .or. &
+ npoin1D_worker2 /= NGLOB1D_RADIAL(iregion_code)) then
+ stop 'incorrect total number of points'
+ else
+ print *,'number of points is correct: ',NGLOB1D_RADIAL(iregion_code)
+ endif
+
+! check all the points based upon their coordinates
+ do ipoin1D = 1, NGLOB1D_RADIAL(iregion_code)
+
+ read(34,*) iboolmaster,xmaster,ymaster,zmaster
+ read(35,*) iboolworker1,xworker1,yworker1,zworker1
+! if only two chunks then there is no second worker
+ if(NCHUNKS /= 2) read(36,*) iboolworker2,xworker2,yworker2,zworker2
+
+ diff1 = dmax1(dabs(xmaster-xworker1),dabs(ymaster-yworker1),dabs(zmaster-zworker1))
+ if(diff1 > 0.0000001d0) then
+ print *,'different : ',ipoin1D,iboolmaster,iboolworker1,diff1
+ print *,'xmaster,xworker1 = ',xmaster,xworker1
+ print *,'ymaster,yworker1 = ',ymaster,yworker1
+ print *,'zmaster,zworker1 = ',zmaster,zworker1
+ stop 'error: different'
+ endif
+
+! if only two chunks then there is no second worker
+ if(NCHUNKS /= 2) then
+ diff2 = dmax1(dabs(xmaster-xworker2),dabs(ymaster-yworker2),dabs(zmaster-zworker2))
+ if(diff2 > 0.0000001d0) then
+ print *,'different : ',ipoin1D,iboolmaster,iboolworker2,diff2
+ print *,'xmaster,xworker2 = ',xmaster,xworker2
+ print *,'ymaster,yworker2 = ',ymaster,yworker2
+ print *,'zmaster,zworker2 = ',zmaster,zworker2
+ stop 'error: different'
+ endif
+ endif
+
+ enddo
+
+ close(34)
+ close(35)
+! if only two chunks then there is no second worker
+ if(NCHUNKS /= 2) close(36)
+
+ enddo
+
+ enddo
+
+ print *
+ print *,'done'
+ print *
+
+ end program check_buffers_corners_chunks
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_faces_chunks.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/check_buffers_faces_chunks.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_faces_chunks.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_buffers_faces_chunks.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,262 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! code to check that all the 2D buffers between chunk faces are okay
+
+ program check_buffers_faces_chunks
+
+ implicit none
+
+ include "constants.h"
+
+ integer imsg
+
+ integer npoin2D_sender,npoin2D_receiver
+ integer iboolsend,iboolreceive,ipoin2D
+ integer iregion_code,iproc
+
+! number of faces between chunks
+ integer NUM_FACES,NUMMSGS_FACES
+
+! number of message types
+ integer NUM_MSG_TYPES
+
+ double precision xsend,ysend,zsend
+ double precision xreceive,yreceive,zreceive
+ double precision diff
+
+ integer NPROC_ONE_DIRECTION
+
+! communication pattern for faces between chunks
+ integer, dimension(:), allocatable :: iprocfrom_faces,iprocto_faces,imsg_type
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ 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
+
+! this is 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
+
+ character(len=150) filename,prname
+
+! computed in read_compute_parameters
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+
+! ************** PROGRAM STARTS HERE **************
+
+ print *
+ print *,'Check all MPI buffers between chunk faces'
+ print *
+
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ print *
+ print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
+ print *,'There are ',NCHUNKS,' chunks'
+ print *,'There are ',NPROC_XI,' slices along xi in each chunk'
+ print *,'There are ',NPROC_ETA,' slices along eta in each chunk'
+ print *
+
+! number of corners and faces shared between chunks and number of message types
+ if(NCHUNKS == 1 .or. NCHUNKS == 2) then
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 1
+ else if(NCHUNKS == 3) then
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 3
+ else if(NCHUNKS == 6) then
+ NUM_FACES = 4
+ NUM_MSG_TYPES = 3
+ else
+ stop '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
+
+ if(NCHUNKS == 1) stop 'only one chunk, nothing to check'
+
+ print *,'There are ',NUMMSGS_FACES,' messages to assemble all the faces'
+ print *
+
+! allocate array for messages for faces
+ allocate(iprocfrom_faces(NUMMSGS_FACES))
+ allocate(iprocto_faces(NUMMSGS_FACES))
+ allocate(imsg_type(NUMMSGS_FACES))
+
+! 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
+ 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) &
+ stop 'incorrect chunk faces numbering'
+ if (imsg_type(imsg) < 1 .or. imsg_type(imsg) > 3) &
+ stop 'incorrect message type labeling'
+ enddo
+ close(IIN)
+
+! loop over all the regions of the mesh
+ do iregion_code = 1,MAX_NUM_REGIONS
+
+ print *
+ print *,' ********* checking region ',iregion_code,' *********'
+ print *
+
+! loop on all the messages between faces
+ do imsg = 1,NUMMSGS_FACES
+
+ print *
+ print *,'Checking message ',imsg,' out of ',NUMMSGS_FACES
+
+! read 2-D buffer for the sender and the receiver
+ write(filename,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
+ iproc = iprocfrom_faces(imsg)
+ call create_serial_name_database(prname,iproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+ open(unit=34,file=prname(1:len_trim(prname))//filename,status='old',action='read')
+
+ write(filename,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
+ iproc = iprocto_faces(imsg)
+ call create_serial_name_database(prname,iproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+ open(unit=35,file=prname(1:len_trim(prname))//filename,status='old',action='read')
+
+ write(*,*) 'reading MPI 2D buffer for sender'
+ read(34,*) npoin2D_sender
+ read(35,*) npoin2D_receiver
+
+! check that number of points is the same in both buffers
+ if(npoin2D_sender /= npoin2D_receiver) &
+ stop 'different number of points in the two buffers'
+
+ print *,'this message contains ',npoin2D_sender,' points'
+
+! check all the points based upon their coordinates
+ do ipoin2D = 1,npoin2D_sender
+ read(34,*) iboolsend,xsend,ysend,zsend
+ read(35,*) iboolreceive,xreceive,yreceive,zreceive
+
+ diff = dmax1(dabs(xsend-xreceive),dabs(ysend-yreceive),dabs(zsend-zreceive))
+ if(diff > 0.0000001d0) then
+ print *,'different : ',ipoin2D,iboolsend,iboolreceive,diff
+ print *,'xsend,xreceive = ',xsend,xreceive
+ print *,'ysend,yreceive = ',ysend,yreceive
+ print *,'zsend,zreceive = ',zsend,zreceive
+ stop 'error: different'
+ endif
+
+ enddo
+
+ enddo
+
+ enddo
+
+ print *
+ print *,'done'
+ print *
+
+ end program check_buffers_faces_chunks
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_simulation_stability.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/check_simulation_stability.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_simulation_stability.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/check_simulation_stability.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,346 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
+ b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
+ eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ myrank) !COMPUTE_AND_STORE_STRAIN,myrank)
+
+ implicit none
+
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ ! time step
+ integer it,NSTEP,myrank
+
+ ! displacement
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: displ_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: b_displ_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_displ_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: b_displ_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
+ eps_trace_over_3_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
+ epsilondev_crust_mantle
+
+ integer SIMULATION_TYPE
+ character(len=150) OUTPUT_FILES
+
+ double precision :: time_start,DT,t0
+
+! logical COMPUTE_AND_STORE_STRAIN
+
+ ! local parameters
+ ! maximum of the norm of the displacement and of the potential in the fluid
+ real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all,Ufluidnorm,Ufluidnorm_all
+ real(kind=CUSTOM_REAL) Strain_norm,Strain_norm_all,strain2_norm,strain2_norm_all
+ real(kind=CUSTOM_REAL) b_Usolidnorm,b_Usolidnorm_all,b_Ufluidnorm,b_Ufluidnorm_all
+ ! names of the data files for all the processors in MPI
+ character(len=150) outputname
+ ! timer MPI
+ double precision :: tCPU,t_remain,t_total
+ integer :: ihours,iminutes,iseconds,int_tCPU, &
+ ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
+ ihours_total,iminutes_total,iseconds_total,int_t_total
+ ! to determine date and time at which the run will finish
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ character(len=3), dimension(12) :: month_name
+ character(len=3), dimension(0:6) :: weekday_name
+ data month_name /'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/
+ data weekday_name /'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'/
+ integer :: year,mon,day,hr,minutes,timestamp,julian_day_number,day_of_week, &
+ timestamp_remote,year_remote,mon_remote,day_remote,hr_remote,minutes_remote,day_of_week_remote
+ integer :: ier
+ integer, external :: idaywk
+
+ double precision,parameter :: scale_displ = R_EARTH
+
+
+ ! 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 (SIMULATION_TYPE == 3) then
+ b_Usolidnorm = max( &
+ maxval(sqrt(b_displ_crust_mantle(1,:)**2 + &
+ b_displ_crust_mantle(2,:)**2 + b_displ_crust_mantle(3,:)**2)), &
+ maxval(sqrt(b_displ_inner_core(1,:)**2 &
+ + b_displ_inner_core(2,:)**2 &
+ + b_displ_inner_core(3,:)**2)))
+
+ b_Ufluidnorm = maxval(abs(b_displ_outer_core))
+
+ ! compute the maximum of the maxima for all the slices using an MPI reduction
+ call MPI_REDUCE(b_Usolidnorm,b_Usolidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
+ MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(b_Ufluidnorm,b_Ufluidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
+ MPI_COMM_WORLD,ier)
+ endif
+
+ if (COMPUTE_AND_STORE_STRAIN) then
+ Strain_norm = maxval(abs(eps_trace_over_3_crust_mantle))
+ strain2_norm= maxval(abs(epsilondev_crust_mantle))
+ call MPI_REDUCE(Strain_norm,Strain_norm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
+ MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(Strain2_norm,Strain2_norm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
+ MPI_COMM_WORLD,ier)
+ endif
+
+ if(myrank == 0) then
+
+ write(IMAIN,*) 'Time step # ',it
+ 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
+
+ if (SIMULATION_TYPE == 3) then
+ b_Usolidnorm_all = b_Usolidnorm_all * sngl(scale_displ)
+ write(IMAIN,*) 'Max norm displacement vector U in solid in all slices for back prop.(m) = ',b_Usolidnorm_all
+ write(IMAIN,*) 'Max non-dimensional potential Ufluid in fluid in all slices for back prop.= ',b_Ufluidnorm_all
+ endif
+
+ if(COMPUTE_AND_STORE_STRAIN) then
+ write(IMAIN,*) 'Max of strain, eps_trace_over_3_crust_mantle =',Strain_norm_all
+ write(IMAIN,*) 'Max of strain, epsilondev_crust_mantle =',Strain2_norm_all
+ endif
+
+ ! 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 < NSTEP) then
+
+ ! get current date
+ call date_and_time(datein,timein,zone,time_values)
+ ! time_values(1): year
+ ! time_values(2): month of the year
+ ! time_values(3): day of the month
+ ! time_values(5): hour of the day
+ ! time_values(6): minutes of the hour
+
+ ! compute date at which the run should finish; for simplicity only minutes
+ ! are considered, seconds are ignored; in any case the prediction is not
+ ! accurate down to seconds because of system and network fluctuations
+ year = time_values(1)
+ mon = time_values(2)
+ day = time_values(3)
+ hr = time_values(5)
+ minutes = time_values(6)
+
+ ! get timestamp in minutes of current date and time
+ call convtime(timestamp,year,mon,day,hr,minutes)
+
+ ! add remaining minutes
+ timestamp = timestamp + nint(t_remain / 60.d0)
+
+ ! get date and time of that future timestamp in minutes
+ call invtime(timestamp,year,mon,day,hr,minutes)
+
+ ! convert to Julian day to get day of the week
+ call calndr(day,mon,year,julian_day_number)
+ day_of_week = idaywk(julian_day_number)
+
+ write(IMAIN,"(' The run will finish approximately on (in local time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
+ weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
+
+ ! print date and time estimate of end of run in another country.
+ ! For instance: the code runs at Caltech in California but the person
+ ! running the code is connected remotely from France, which has 9 hours more
+ if(ADD_TIME_ESTIMATE_ELSEWHERE .and. HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE /= 0) then
+
+ ! add time difference with that remote location (can be negative)
+ timestamp_remote = timestamp + HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE
+
+ ! get date and time of that future timestamp in minutes
+ call invtime(timestamp_remote,year_remote,mon_remote,day_remote,hr_remote,minutes_remote)
+
+ ! convert to Julian day to get day of the week
+ call calndr(day_remote,mon_remote,year_remote,julian_day_number)
+ day_of_week_remote = idaywk(julian_day_number)
+
+ if(HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE > 0) then
+ write(IMAIN,*) 'Adding positive time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
+ else
+ write(IMAIN,*) 'Adding negative time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
+ endif
+ write(IMAIN,*) 'and ',abs(MINUTES_TIME_DIFFERENCE),' minutes to get estimate at a remote location'
+ write(IMAIN, &
+ "(' The run will finish approximately on: ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
+ weekday_name(day_of_week_remote),month_name(mon_remote),day_remote,year_remote,hr_remote,minutes_remote
+ endif
+
+ if(it < 100) then
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '**** BEWARE: the above time estimates are not reliable'
+ write(IMAIN,*) '**** because fewer than 100 iterations have been performed'
+ write(IMAIN,*) '************************************************************'
+ endif
+
+ endif
+
+ write(IMAIN,*)
+
+ ! write time stamp file to give information about progression of simulation
+ write(outputname,"('/timestamp',i6.6)") it
+
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',action='write')
+
+ write(IOUT,*) 'Time step # ',it
+ write(IOUT,*) 'Time: ',sngl(((it-1)*DT-t0)/60.d0),' minutes'
+ write(IOUT,*)
+ write(IOUT,*) 'Max norm displacement vector U in solid in all slices (m) = ',Usolidnorm_all
+ write(IOUT,*) 'Max non-dimensional potential Ufluid in fluid in all slices = ',Ufluidnorm_all
+ write(IOUT,*)
+
+ if (SIMULATION_TYPE == 3) then
+ write(IOUT,*) 'Max norm displacement vector U in solid in all slices for back prop.(m) = ',b_Usolidnorm_all
+ write(IOUT,*) 'Max non-dimensional potential Ufluid in fluid in all slices for back prop.= ',b_Ufluidnorm_all
+ write(IOUT,*)
+ endif
+
+ write(IOUT,*) 'Elapsed time in seconds = ',tCPU
+ write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(IOUT,*)
+
+ write(IOUT,*) 'Time steps done = ',it,' out of ',NSTEP
+ write(IOUT,*) 'Time steps remaining = ',NSTEP - it
+ write(IOUT,*) 'Estimated remaining time in seconds = ',t_remain
+ write(IOUT,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_remain,iminutes_remain,iseconds_remain
+ write(IOUT,*)
+
+ write(IOUT,*) 'Estimated total run time in seconds = ',t_total
+ write(IOUT,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_total,iminutes_total,iseconds_total
+ write(IOUT,*) 'We have done ',sngl(100.d0*dble(it)/dble(NSTEP)),'% of that'
+ write(IOUT,*)
+
+ if(it < NSTEP) then
+
+ write(IOUT,"(' The run will finish approximately on (in local time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
+ weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
+
+ ! print date and time estimate of end of run in another country.
+ ! For instance: the code runs at Caltech in California but the person
+ ! running the code is connected remotely from France, which has 9 hours more
+ if(ADD_TIME_ESTIMATE_ELSEWHERE .and. HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE /= 0) then
+ if(HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE > 0) then
+ write(IOUT,*) 'Adding positive time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
+ else
+ write(IOUT,*) 'Adding negative time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
+ endif
+ write(IOUT,*) 'and ',abs(MINUTES_TIME_DIFFERENCE),' minutes to get estimate at a remote location'
+ write(IOUT, &
+ "(' The run will finish approximately on (in remote time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
+ weekday_name(day_of_week_remote),month_name(mon_remote), &
+ day_remote,year_remote,hr_remote,minutes_remote
+ endif
+
+ if(it < 100) then
+ write(IOUT,*)
+ write(IOUT,*) '************************************************************'
+ write(IOUT,*) '**** BEWARE: the above time estimates are not reliable'
+ write(IOUT,*) '**** because fewer than 100 iterations have been performed'
+ write(IOUT,*) '************************************************************'
+ endif
+
+ endif
+
+ close(IOUT)
+
+ ! check stability of the code, exit if unstable
+ ! negative values can occur with some compilers when the unstable value is greater
+ ! than the greatest possible floating-point number of the machine
+ if(Usolidnorm_all > STABILITY_THRESHOLD .or. Usolidnorm_all < 0) &
+ call exit_MPI(myrank,'forward simulation became unstable and blew up in the solid')
+ if(Ufluidnorm_all > STABILITY_THRESHOLD .or. Ufluidnorm_all < 0) &
+ call exit_MPI(myrank,'forward simulation became unstable and blew up in the fluid')
+
+ if(SIMULATION_TYPE == 3) then
+ if(b_Usolidnorm_all > STABILITY_THRESHOLD .or. b_Usolidnorm_all < 0) &
+ call exit_MPI(myrank,'backward simulation became unstable and blew up in the solid')
+ if(b_Ufluidnorm_all > STABILITY_THRESHOLD .or. b_Ufluidnorm_all < 0) &
+ call exit_MPI(myrank,'backward simulation became unstable and blew up in the fluid')
+ endif
+
+ endif
+
+ end subroutine check_simulation_stability
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_AVS_DX.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/combine_AVS_DX.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_AVS_DX.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_AVS_DX.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1214 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! combine AVS or DX global data files to check the mesh
+! this is done in postprocessing after running the mesh generator
+
+ program combine_AVS_DX
+
+ implicit none
+
+ include "constants.h"
+
+! threshold for number of points per wavelength displayed
+! otherwise the scale is too large and we cannot see the small values
+! all values above this threshold are truncated
+ double precision, parameter :: THRESHOLD_GRIDPOINTS = 12.
+
+! non-linear scaling factor for elevation if topography for Earth model
+ double precision, parameter :: SCALE_NON_LINEAR = 0.3
+
+! maximum polynomial degree for which we can compute the stability condition
+ integer, parameter :: NGLL_MAX_STABILITY = 15
+
+ integer iproc,nspec,npoin
+ integer ispec
+ integer iglob1,iglob2,iglob3,iglob4
+ integer ipoin,numpoin,numpoin2,iglobpointoffset,ntotpoin,ntotspec
+ integer numelem,numelem2,iglobelemoffset,idoubling,maxdoubling
+ integer iformat,ivalue,icolor,itarget_doubling
+ integer imaterial,imatprop,ispec_scale_AVS_DX
+ integer nrec,ir,iregion_code
+ integer ntotpoinAVS_DX,ntotspecAVS_DX
+
+ real(kind=CUSTOM_REAL) vmin,vmax,deltavp,deltavs
+ double precision xval,yval,zval
+ double precision val_color,rnorm_factor
+
+ logical threshold_used
+ logical USE_OPENDX
+
+! for source location
+ integer yr,jda,ho,mi
+ double precision x_target_source,y_target_source,z_target_source
+ double precision r_target_source
+ double precision x_source_trgl1,y_source_trgl1,z_source_trgl1
+ double precision x_source_trgl2,y_source_trgl2,z_source_trgl2
+ double precision x_source_trgl3,y_source_trgl3,z_source_trgl3
+ double precision theta,phi,delta_trgl
+ double precision sec,min_tshift_cmt_original !,tshift_cmt,hdur
+ !double precision lat,long,depth
+ double precision, dimension(1) :: tshift_cmt,hdur,lat,long,depth
+
+ double precision moment_tensor(6)
+
+! for receiver location
+ integer irec,ios
+ double precision r_target
+ double precision, allocatable, dimension(:) :: stlat,stlon,stele,stbur
+ character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
+ character(len=150) dummystring
+
+ double precision, allocatable, dimension(:) :: x_target,y_target,z_target
+
+! for the reference ellipsoid
+ double precision reference,radius_dummy,theta_s,phi_s
+
+! processor identification
+ character(len=150) prname
+
+! small offset for source and receiver line in AVS_DX
+! (small compared to normalized radius of the Earth)
+
+! for full Earth
+ double precision, parameter :: small_offset_source_earth = 0.025d0
+ double precision, parameter :: small_offset_receiver_earth = 0.0125d0
+
+! for oceans only
+ logical OCEANS_ONLY
+ integer ioceans
+ integer above_zero,below_zero
+
+! for stability condition
+ double precision, dimension (:), allocatable :: stability_value,gridpoints_per_wavelength,elevation_sphere
+ double precision, dimension (:), allocatable :: dvp,dvs
+ double precision, dimension (:), allocatable :: xcoord,ycoord,zcoord,vmincoord,vmaxcoord
+ double precision stability_value_min,stability_value_max
+ double precision gridpoints_per_wavelength_min,gridpoints_per_wavelength_max
+ integer iloop_corners,istab,jstab
+ integer ipointnumber1_horiz,ipointnumber2_horiz
+ integer ipointnumber1_vert,ipointnumber2_vert
+ double precision distance_horiz,distance_vert
+ double precision stabmax,gridmin,scale_factor
+ integer NGLL_current_horiz,NGLL_current_vert
+ double precision :: percent_GLL(NGLL_MAX_STABILITY)
+
+! for chunk numbering
+ integer iproc_read,ichunk,idummy1,idummy2
+ integer, dimension(:), allocatable :: ichunk_slice
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ RMOHO_FICTITIOUS_IN_MESHER
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ 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
+
+! for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC_COMP, &
+ 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 region_min,region_max
+
+ double precision small_offset_source,small_offset_receiver
+
+ integer proc_p1,proc_p2
+
+! computed in read_compute_parameters
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+
+! ************** PROGRAM STARTS HERE **************
+
+ print *
+ print *,'Recombining all AVS or DX files for slices'
+ print *
+
+ print *
+ print *,'reading parameter file'
+ print *
+
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,&
+ MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC_COMP,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX,&
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,&
+ this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,&
+ HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,&
+ USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
+
+ if(.not. SAVE_MESH_FILES) stop 'AVS or DX files were not saved by the mesher'
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ print *,'1 = create files in OpenDX format'
+ print *,'2 = create files in AVS UCD format'
+ print *,'any other value = exit'
+ print *
+ print *,'enter value:'
+ read(5,*) iformat
+ if(iformat<1 .or. iformat>2) stop 'exiting...'
+ if(iformat == 1) then
+ USE_OPENDX = .true.
+ else
+ USE_OPENDX = .false.
+ endif
+
+ print *
+ print *,'1 = edges of all the slices only'
+ print *,'2 = edges of the chunks only'
+ print *,'3 = surface of the model only'
+ print *,'any other value = exit'
+ print *
+ print *,'enter value:'
+ read(5,*) ivalue
+ if(ivalue<1 .or. ivalue>3) stop 'exiting...'
+
+! warning if surface elevation
+ if(ivalue == 3) then
+ print *,'******************************************'
+ print *,'*** option 7 to color using topography ***'
+ print *,'******************************************'
+ endif
+
+ print *
+ print *,'1 = color by doubling flag'
+ print *,'2 = by slice number'
+ print *,'3 = by stability value'
+ print *,'4 = by gridpoints per wavelength'
+ print *,'5 = dvp/vp'
+ print *,'6 = dvs/vs'
+ print *,'7 = elevation of Earth model'
+ print *,'8 = by region number'
+ print *,'9 = focus on one doubling flag only'
+ print *,'any other value=exit'
+ print *
+ print *,'enter value:'
+ read(5,*) icolor
+ if(icolor<1 .or. icolor >9) stop 'exiting...'
+ if((icolor == 3 .or. icolor == 4) .and. ivalue /= 2) &
+ stop 'need chunks only to represent stability or gridpoints per wavelength'
+
+ if(icolor == 9) then
+ print *
+ print *,'enter value of target doubling flag:'
+ read(5,*) itarget_doubling
+ endif
+
+! for oceans only
+ OCEANS_ONLY = .false.
+ if(ivalue == 3 .and. icolor == 7) then
+ print *
+ print *,'1 = represent full topography (topo + oceans)'
+ print *,'2 = represent oceans only'
+ print *
+ read(5,*) ioceans
+ if(ioceans == 1) then
+ OCEANS_ONLY = .false.
+ else if(ioceans == 2) then
+ OCEANS_ONLY = .true.
+ else
+ stop 'incorrect option for the oceans'
+ endif
+ endif
+
+ print *
+ print *,'1 = material property by doubling flag'
+ print *,'2 = by slice number'
+ print *,'3 = by region number'
+ print *,'4 = by chunk number'
+ print *,'any other value=exit'
+ print *
+ print *,'enter value:'
+ read(5,*) imaterial
+ if(imaterial < 1 .or. imaterial > 4) stop 'exiting...'
+
+! user can specify a range of processors here
+ print *
+ print *,'enter first proc (proc numbers start at 0) = '
+ read(5,*) proc_p1
+ if(proc_p1 < 0) proc_p1 = 0
+ if(proc_p1 > NPROCTOT-1) proc_p1 = NPROCTOT-1
+
+ print *,'enter last proc (enter -1 for all procs) = '
+ read(5,*) proc_p2
+ if(proc_p2 == -1) proc_p2 = NPROCTOT-1
+ if(proc_p2 < 0) proc_p2 = 0
+ if(proc_p2 > NPROCTOT-1) proc_p2 = NPROCTOT-1
+
+! set interval to maximum if user input is not correct
+ if(proc_p1 <= 0) proc_p1 = 0
+ if(proc_p2 < 0) proc_p2 = NPROCTOT - 1
+
+ print *
+ print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
+ print *
+
+! open file with global slice number addressing
+ write(*,*) 'reading slice addressing'
+ write(*,*)
+ allocate(ichunk_slice(0:NPROCTOT-1))
+
+ open(unit=IIN,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read')
+ do iproc = 0,NPROCTOT-1
+ read(IIN,*) iproc_read,ichunk,idummy1,idummy2
+ if(iproc_read /= iproc) stop 'incorrect slice number read'
+ ichunk_slice(iproc) = ichunk
+ enddo
+ close(IIN)
+
+! define percentage of smallest distance between GLL points for NGLL points
+! percentages were computed by calling the GLL points routine for each degree
+ percent_GLL(2) = 100.d0
+ percent_GLL(3) = 50.d0
+ percent_GLL(4) = 27.639320225002102d0
+ percent_GLL(5) = 17.267316464601141d0
+ percent_GLL(6) = 11.747233803526763d0
+ percent_GLL(7) = 8.4888051860716516d0
+ percent_GLL(8) = 6.4129925745196719d0
+ percent_GLL(9) = 5.0121002294269914d0
+ percent_GLL(10) = 4.0233045916770571d0
+ percent_GLL(11) = 3.2999284795970416d0
+ percent_GLL(12) = 2.7550363888558858d0
+ percent_GLL(13) = 2.3345076678918053d0
+ percent_GLL(14) = 2.0032477366369594d0
+ percent_GLL(15) = 1.7377036748080721d0
+
+! convert to real percentage
+ percent_GLL(:) = percent_GLL(:) / 100.d0
+
+! clear flag to detect if threshold used
+ threshold_used = .false.
+
+! set length of segments for source and receiver representation
+ small_offset_source = small_offset_source_earth
+ small_offset_receiver = small_offset_receiver_earth
+
+! set total number of points and elements to zero
+ ntotpoin = 0
+ ntotspec = 0
+
+ region_min = 1
+ region_max = MAX_NUM_REGIONS
+
+! if representing surface elements, only one region
+ if(ivalue == 3) then
+ region_min = IREGION_CRUST_MANTLE
+ region_max = IREGION_CRUST_MANTLE
+ endif
+
+ do iregion_code = region_min,region_max
+
+! loop on the selected range of processors
+ do iproc = proc_p1,proc_p2
+
+ print *,'Reading slice ',iproc,' in region ',iregion_code
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,iproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+
+ if(ivalue == 1) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read')
+ else if(ivalue == 2) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='old',action='read')
+ else if(ivalue == 3) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
+ endif
+
+ read(10,*) npoin
+ print *,'There are ',npoin,' global AVS or DX points in the slice'
+ ntotpoin = ntotpoin + npoin
+ close(10)
+
+ if(ivalue == 1) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read')
+ else if(ivalue == 2) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='old',action='read')
+ else if(ivalue == 3) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read')
+ endif
+
+ read(10,*) nspec
+ print *,'There are ',nspec,' AVS or DX elements in the slice'
+ ntotspec = ntotspec + nspec
+ close(10)
+
+ enddo
+ enddo
+
+ print *
+ print *,'There is a total of ',ntotspec,' elements in all the slices'
+ print *,'There is a total of ',ntotpoin,' points in all the slices'
+ print *
+
+ ntotpoinAVS_DX = ntotpoin
+ ntotspecAVS_DX = ntotspec
+
+! write AVS or DX header with element data
+ if(USE_OPENDX) then
+ open(unit=11,file=trim(OUTPUT_FILES)//'/DX_fullmesh.dx',status='unknown')
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ntotpoinAVS_DX,' data follows'
+ else
+ open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_fullmesh.inp',status='unknown')
+ write(11,*) ntotpoinAVS_DX,' ',ntotspecAVS_DX,' 0 1 0'
+ endif
+
+! allocate array for stability condition
+ allocate(stability_value(ntotspecAVS_DX))
+ allocate(gridpoints_per_wavelength(ntotspecAVS_DX))
+ allocate(elevation_sphere(ntotspecAVS_DX))
+ allocate(dvp(ntotspecAVS_DX))
+ allocate(dvs(ntotspecAVS_DX))
+ allocate(xcoord(ntotpoinAVS_DX))
+ allocate(ycoord(ntotpoinAVS_DX))
+ allocate(zcoord(ntotpoinAVS_DX))
+ allocate(vmincoord(ntotpoinAVS_DX))
+ allocate(vmaxcoord(ntotpoinAVS_DX))
+
+! ************* generate points ******************
+
+! set global point offset to zero
+ iglobpointoffset = 0
+
+ do iregion_code = region_min,region_max
+
+! loop on the selected range of processors
+ do iproc=proc_p1,proc_p2
+
+ print *,'Reading slice ',iproc,' in region ',iregion_code
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,iproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+
+ if(ivalue == 1) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read')
+ else if(ivalue == 2) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='old',action='read')
+ open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointschunks_stability.txt',status='old',action='read')
+ else if(ivalue == 3) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
+ endif
+
+ read(10,*) npoin
+ print *,'There are ',npoin,' global AVS or DX points in the slice'
+
+! read local points in this slice and output global AVS or DX points
+ do ipoin=1,npoin
+ read(10,*) numpoin,xval,yval,zval
+ if(ivalue == 2) then
+ read(12,*) numpoin2,vmin,vmax
+ else
+ numpoin2 = 0
+ vmin = 0.
+ vmax = 0.
+ endif
+ if(numpoin /= ipoin) stop 'incorrect point number'
+ if(ivalue == 2 .and. numpoin2 /= ipoin) stop 'incorrect point number'
+! write to AVS or DX global file with correct offset
+ if(USE_OPENDX) then
+ write(11,"(f10.7,1x,f10.7,1x,f10.7)") xval,yval,zval
+ else
+ write(11,"(i6,1x,f10.7,1x,f10.7,1x,f10.7)") numpoin + iglobpointoffset,xval,yval,zval
+ endif
+
+! save coordinates in global array of points for stability condition
+ xcoord(numpoin + iglobpointoffset) = xval
+ ycoord(numpoin + iglobpointoffset) = yval
+ zcoord(numpoin + iglobpointoffset) = zval
+ vmincoord(numpoin + iglobpointoffset) = vmin
+ vmaxcoord(numpoin + iglobpointoffset) = vmax
+
+ enddo
+
+ iglobpointoffset = iglobpointoffset + npoin
+
+ close(10)
+ if(ivalue == 2) close(12)
+
+ enddo
+ enddo
+
+! ************* generate elements ******************
+
+! get source information for frequency for number of points per lambda
+ print *,'reading source duration from the CMTSOLUTION file'
+ call get_cmt(yr,jda,ho,mi,sec,tshift_cmt,hdur,lat,long,depth,moment_tensor, &
+ DT,1,min_tshift_cmt_original)
+
+! set global element and point offsets to zero
+ iglobpointoffset = 0
+ iglobelemoffset = 0
+ maxdoubling = -1
+ above_zero = 0
+ below_zero = 0
+
+ if(USE_OPENDX) write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows'
+
+ do iregion_code = region_min,region_max
+
+! loop on the selected range of processors
+ do iproc=proc_p1,proc_p2
+
+ print *,'Reading slice ',iproc,' in region ',iregion_code
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,iproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+
+ if(ivalue == 1) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read')
+ open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read')
+ if(icolor == 5 .or. icolor == 6) &
+ open(unit=13,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces_dvp_dvs.txt',status='old',action='read')
+ else if(ivalue == 2) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='old',action='read')
+ if(icolor == 5 .or. icolor == 6) &
+ open(unit=13,file=prname(1:len_trim(prname))//'AVS_DXelementschunks_dvp_dvs.txt',status='old',action='read')
+ open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='old',action='read')
+ else if(ivalue == 3) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read')
+ open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
+ if(icolor == 5 .or. icolor == 6) &
+ open(unit=13,file=prname(1:len_trim(prname))//'AVS_DXelementssurface_dvp_dvs.txt',status='old',action='read')
+
+ endif
+
+ read(10,*) nspec
+ read(12,*) npoin
+ print *,'There are ',npoin,' global AVS or DX points in the slice'
+ print *,'There are ',nspec,' AVS or DX elements in the slice'
+
+! read local elements in this slice and output global AVS or DX elements
+ do ispec=1,nspec
+ read(10,*) numelem,idoubling,iglob1,iglob2,iglob3,iglob4
+ if(icolor == 5 .or. icolor == 6) then
+ read(13,*) numelem2,deltavp,deltavs
+ dvp(numelem + iglobelemoffset) = deltavp
+ dvs(numelem + iglobelemoffset) = deltavs
+ else
+ numelem2 = 0
+ endif
+ if(numelem /= ispec) stop 'incorrect element number'
+ if((icolor == 5 .or. icolor == 6) .and. numelem2 /= ispec) stop 'incorrect element number'
+! compute max of the doubling flag
+ maxdoubling = max(maxdoubling,idoubling)
+
+! assign material property (which can be filtered later in AVS_DX)
+ if(imaterial == 1) then
+ imatprop = idoubling
+ else if(imaterial == 2) then
+ imatprop = iproc
+ else if(imaterial == 3) then
+ imatprop = iregion_code
+ else if(imaterial == 4) then
+ imatprop = ichunk_slice(iproc)
+ else
+ stop 'invalid code for material property'
+ endif
+
+! write to AVS or DX global file with correct offset
+
+! quadrangles (2-D)
+ iglob1 = iglob1 + iglobpointoffset
+ iglob2 = iglob2 + iglobpointoffset
+ iglob3 = iglob3 + iglobpointoffset
+ iglob4 = iglob4 + iglobpointoffset
+
+! in the case of OpenDX, node numbers start at zero
+! in the case of AVS, node numbers start at one
+ if(USE_OPENDX) then
+! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
+ write(11,"(i6,1x,i6,1x,i6,1x,i6)") iglob1-1,iglob4-1,iglob2-1,iglob3-1
+ else
+ write(11,"(i6,1x,i3,' quad ',i6,1x,i6,1x,i6,1x,i6)") numelem + iglobelemoffset,imatprop,iglob1,iglob2,iglob3,iglob4
+ endif
+
+! get number of GLL points in current element
+ NGLL_current_horiz = NGLLX
+ NGLL_current_vert = NGLLZ
+
+! check that the degree is not above the threshold for list of percentages
+ if(NGLL_current_horiz > NGLL_MAX_STABILITY .or. &
+ NGLL_current_vert > NGLL_MAX_STABILITY) &
+ stop 'degree too high to compute stability value'
+
+! scaling factor to compute real value of stability condition
+ scale_factor = dsqrt(PI*GRAV*RHOAV)
+
+! compute stability value
+ stabmax = -1.d0
+ gridmin = HUGEVAL
+
+ if(idoubling == IFLAG_CRUST) then
+
+! distinguish between horizontal and vertical directions in crust
+! because we have a different polynomial degree in each direction
+! this works because the mesher always creates the 2D surfaces starting
+! from the lower-left corner, continuing to the lower-right corner and so on
+ do iloop_corners = 1,2
+
+ select case(iloop_corners)
+
+ case(1)
+ ipointnumber1_horiz = iglob1
+ ipointnumber2_horiz = iglob2
+
+ ipointnumber1_vert = iglob1
+ ipointnumber2_vert = iglob4
+
+ case(2)
+ ipointnumber1_horiz = iglob4
+ ipointnumber2_horiz = iglob3
+
+ ipointnumber1_vert = iglob2
+ ipointnumber2_vert = iglob3
+
+ end select
+
+ distance_horiz = &
+ dsqrt((xcoord(ipointnumber2_horiz)-xcoord(ipointnumber1_horiz))**2 &
+ + (ycoord(ipointnumber2_horiz)-ycoord(ipointnumber1_horiz))**2 &
+ + (zcoord(ipointnumber2_horiz)-zcoord(ipointnumber1_horiz))**2)
+
+ distance_vert = &
+ dsqrt((xcoord(ipointnumber2_vert)-xcoord(ipointnumber1_vert))**2 &
+ + (ycoord(ipointnumber2_vert)-ycoord(ipointnumber1_vert))**2 &
+ + (zcoord(ipointnumber2_vert)-zcoord(ipointnumber1_vert))**2)
+
+! compute stability value using the scaled interval
+ stabmax = dmax1(scale_factor*DT*vmaxcoord(ipointnumber1_horiz)/(distance_horiz*percent_GLL(NGLL_current_horiz)),stabmax)
+ stabmax = dmax1(scale_factor*DT*vmaxcoord(ipointnumber1_vert)/(distance_vert*percent_GLL(NGLL_current_vert)),stabmax)
+
+! compute number of points per wavelength
+ gridmin = dmin1(scale_factor*hdur(1)*vmincoord(ipointnumber1_horiz)*dble(NGLL_current_horiz)/distance_horiz,gridmin)
+ gridmin = dmin1(scale_factor*hdur(1)*vmincoord(ipointnumber1_vert)*dble(NGLL_current_vert)/distance_vert,gridmin)
+
+ enddo
+
+! regular regions with same polynomial degree everywhere
+
+ else
+
+ do istab = 1,4
+ do jstab = 1,4
+ if(jstab /= istab) then
+
+ if(istab == 1) then
+ ipointnumber1_vert = iglob1
+ else if(istab == 2) then
+ ipointnumber1_vert = iglob2
+ else if(istab == 3) then
+ ipointnumber1_vert = iglob3
+ else if(istab == 4) then
+ ipointnumber1_vert = iglob4
+ endif
+
+ if(jstab == 1) then
+ ipointnumber2_vert = iglob1
+ else if(jstab == 2) then
+ ipointnumber2_vert = iglob2
+ else if(jstab == 3) then
+ ipointnumber2_vert = iglob3
+ else if(jstab == 4) then
+ ipointnumber2_vert = iglob4
+ endif
+
+ distance_vert = &
+ dsqrt((xcoord(ipointnumber2_vert)-xcoord(ipointnumber1_vert))**2 &
+ + (ycoord(ipointnumber2_vert)-ycoord(ipointnumber1_vert))**2 &
+ + (zcoord(ipointnumber2_vert)-zcoord(ipointnumber1_vert))**2)
+
+! compute stability value using the scaled interval
+ stabmax = dmax1(scale_factor*DT*vmaxcoord(ipointnumber1_vert)/(distance_vert*percent_GLL(NGLL_current_vert)),stabmax)
+
+! compute number of points per wavelength
+ gridmin = dmin1(scale_factor*hdur(1)*vmincoord(ipointnumber1_vert)*dble(NGLL_current_vert)/distance_vert,gridmin)
+
+ endif
+ enddo
+ enddo
+
+ endif
+
+ stability_value(numelem + iglobelemoffset) = stabmax
+ gridpoints_per_wavelength(numelem + iglobelemoffset) = gridmin
+
+! compute elevation to represent ellipticity or topography at the surface
+! use point iglob1 for instance and subtract reference
+
+! get colatitude and longitude of current point
+ xval = xcoord(iglob1)
+ yval = ycoord(iglob1)
+ zval = zcoord(iglob1)
+
+ call xyz_2_rthetaphi_dble(xval,yval,zval,radius_dummy,theta_s,phi_s)
+ call reduce(theta_s,phi_s)
+
+! if topography then subtract reference ellipsoid or sphere for color code
+! if ellipticity then subtract reference sphere for color code
+! otherwise subtract nothing
+ if(TOPOGRAPHY .or. CRUSTAL) then
+ if(ELLIPTICITY) then
+ reference = 1.d0 - (3.d0*dcos(theta_s)**2 - 1.d0)/3.d0/299.8d0
+ else
+ reference = R_UNIT_SPHERE
+ endif
+ else if(ELLIPTICITY) then
+ reference = R_UNIT_SPHERE
+ else
+ reference = 0.
+ endif
+
+! compute elevation
+ elevation_sphere(numelem + iglobelemoffset) = &
+ (dsqrt(xval**2 + yval**2 + zval**2) - reference)
+
+ enddo
+
+ iglobelemoffset = iglobelemoffset + nspec
+ iglobpointoffset = iglobpointoffset + npoin
+
+ close(10)
+ close(12)
+ if(icolor == 5 .or. icolor == 6) close(13)
+
+ enddo
+ enddo
+
+! saturate color scale for elevation since small values
+! apply non linear scaling if topography to enhance regions around sea level
+
+ if(TOPOGRAPHY .or. CRUSTAL) then
+
+! compute absolute maximum
+ rnorm_factor = maxval(dabs(elevation_sphere(:)))
+
+! map to [-1,1]
+ elevation_sphere(:) = elevation_sphere(:) / rnorm_factor
+
+! apply non-linear scaling
+ do ispec_scale_AVS_DX = 1,ntotspecAVS_DX
+
+ xval = elevation_sphere(ispec_scale_AVS_DX)
+
+! compute total area consisting of oceans
+! and suppress areas that are not considered oceans if needed
+! use arbitrary threshold to suppress artefacts in ETOPO5 model
+ if(xval >= -0.018) then
+ if(OCEANS_ONLY) xval = 0.
+ above_zero = above_zero + 1
+ else
+ below_zero = below_zero + 1
+ endif
+
+ if(xval >= 0.) then
+ if(.not. OCEANS_ONLY) then
+ elevation_sphere(ispec_scale_AVS_DX) = xval ** SCALE_NON_LINEAR
+ else
+ elevation_sphere(ispec_scale_AVS_DX) = 0.
+ endif
+ else
+ elevation_sphere(ispec_scale_AVS_DX) = - dabs(xval) ** SCALE_NON_LINEAR
+ endif
+
+ enddo
+
+ else
+
+! regular scaling to real distance if no topography
+ elevation_sphere(:) = R_EARTH * elevation_sphere(:)
+
+ endif
+
+ if(icolor == 5 .or. icolor == 6) then
+
+ if(ISOTROPIC_3D_MANTLE) then
+
+! compute absolute maximum for dvp
+ rnorm_factor = maxval(dabs(dvp(:)))
+
+! map to [-1,1]
+ dvp(:) = dvp(:) / rnorm_factor
+
+! apply non-linear scaling
+ do ispec_scale_AVS_DX = 1,ntotspecAVS_DX
+ xval = dvp(ispec_scale_AVS_DX)
+ if(xval >= 0.) then
+ dvp(ispec_scale_AVS_DX) = xval ** SCALE_NON_LINEAR
+ else
+ dvp(ispec_scale_AVS_DX) = - dabs(xval) ** SCALE_NON_LINEAR
+ endif
+ enddo
+
+! compute absolute maximum for dvs
+ rnorm_factor = maxval(dabs(dvs(:)))
+
+! map to [-1,1]
+ dvs(:) = dvs(:) / rnorm_factor
+
+! apply non-linear scaling
+ do ispec_scale_AVS_DX = 1,ntotspecAVS_DX
+ xval = dvs(ispec_scale_AVS_DX)
+ if(xval >= 0.) then
+ dvs(ispec_scale_AVS_DX) = xval ** SCALE_NON_LINEAR
+ else
+ dvs(ispec_scale_AVS_DX) = - dabs(xval) ** SCALE_NON_LINEAR
+ endif
+ enddo
+
+ endif
+ endif
+
+! ************* generate element data values ******************
+
+! output AVS or DX header for data
+ if(USE_OPENDX) then
+ write(11,*) 'attribute "element type" string "quads"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
+ else
+ write(11,*) '1 1'
+ write(11,*) 'Zcoord, meters'
+ endif
+
+! set global element and point offsets to zero
+ iglobelemoffset = 0
+
+ do iregion_code = region_min,region_max
+
+! loop on the selected range of processors
+ do iproc=proc_p1,proc_p2
+
+ print *,'Reading slice ',iproc,' in region ',iregion_code
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,iproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+
+ if(ivalue == 1) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read')
+ else if(ivalue == 2) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='old',action='read')
+ else if(ivalue == 3) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read')
+ endif
+
+ read(10,*) nspec
+ print *,'There are ',nspec,' AVS or DX elements in the slice'
+
+! read local elements in this slice and output global AVS or DX elements
+ do ispec=1,nspec
+ read(10,*) numelem,idoubling,iglob1,iglob2,iglob3,iglob4
+ if(numelem /= ispec) stop 'incorrect element number'
+
+! data is either the slice number or the mesh doubling region flag
+ if(icolor == 1) then
+ val_color = dble(idoubling)
+ else if(icolor == 2) then
+ val_color = dble(iproc)
+ else if(icolor == 3) then
+ val_color = stability_value(numelem + iglobelemoffset)
+ else if(icolor == 4) then
+ val_color = gridpoints_per_wavelength(numelem + iglobelemoffset)
+! put a threshold for number of points per wavelength displayed
+! otherwise the scale is too large and we cannot see the small values
+ if(val_color > THRESHOLD_GRIDPOINTS) then
+ val_color = THRESHOLD_GRIDPOINTS
+ threshold_used = .true.
+ endif
+ else if(icolor == 5) then
+! minus sign to get the color scheme right: blue is fast (+) and red is slow (-)
+ val_color = -dvp(numelem + iglobelemoffset)
+ else if(icolor == 6) then
+! minus sign to get the color scheme right: blue is fast (+) and red is slow (-)
+ val_color = -dvs(numelem + iglobelemoffset)
+ else if(icolor == 7) then
+ val_color = elevation_sphere(numelem + iglobelemoffset)
+
+ else if(icolor == 8) then
+ val_color = iregion_code
+ else if(icolor == 9) then
+ if(idoubling == itarget_doubling) then
+ val_color = dble(iregion_code)
+ else
+ val_color = dble(IFLAG_DUMMY)
+ endif
+ else
+ stop 'incorrect coloring code'
+ endif
+
+! write to AVS or DX global file with correct offset
+ if(USE_OPENDX) then
+ write(11,*) sngl(val_color)
+ else
+ write(11,*) numelem + iglobelemoffset,' ',sngl(val_color)
+ endif
+ enddo
+
+ iglobelemoffset = iglobelemoffset + nspec
+
+ close(10)
+
+ enddo
+ enddo
+
+! define OpenDX field
+ if(USE_OPENDX) then
+ write(11,*) 'attribute "dep" string "connections"'
+ write(11,*) 'object "irregular positions irregular connections" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+ endif
+
+ close(11)
+
+ print *
+ print *,'maximum value of doubling flag in all slices = ',maxdoubling
+ print *
+
+! print min and max of stability and points per lambda
+
+ if(ivalue == 2) then
+
+! compute minimum and maximum of stability value and points per wavelength
+
+ stability_value_min = minval(stability_value)
+ stability_value_max = maxval(stability_value)
+
+ gridpoints_per_wavelength_min = minval(gridpoints_per_wavelength)
+ gridpoints_per_wavelength_max = maxval(gridpoints_per_wavelength)
+
+ print *
+ print *,'stability value min, max, ratio = ', &
+ stability_value_min,stability_value_max,stability_value_max / stability_value_min
+
+ print *
+ print *,'number of points per wavelength min, max, ratio = ', &
+ gridpoints_per_wavelength_min,gridpoints_per_wavelength_max, &
+ gridpoints_per_wavelength_max / gridpoints_per_wavelength_min
+
+ print *
+ print *,'half duration of ',sngl(hdur(1)),' s used for points per wavelength'
+ print *
+
+ if(hdur(1) < 5.*DT) then
+ print *,'***************************************************************'
+ print *,'Source time function is a Heaviside, points per wavelength meaningless'
+ print *,'***************************************************************'
+ print *
+ endif
+
+ if(icolor == 4 .and. threshold_used) then
+ print *,'***************************************************************'
+ print *,'the number of points per wavelength have been cut above a threshold'
+ print *,'of ',THRESHOLD_GRIDPOINTS,' to avoid saturation of color scale'
+ print *,'***************************************************************'
+ print *
+ endif
+ endif
+
+! if we have the surface for the Earth, print min and max of elevation
+
+ if(ivalue == 3) then
+ print *
+ print *,'elevation min, max = ',minval(elevation_sphere),maxval(elevation_sphere)
+ if(TOPOGRAPHY .or. CRUSTAL) print *,'elevation has been normalized for topography'
+ print *
+
+! print percentage of oceans at surface of the globe
+ print *
+ print *,'the oceans represent ',100. * below_zero / (above_zero + below_zero),' % of the surface of the mesh'
+ print *
+
+ endif
+
+!
+! create an AVS or DX file with the source and the receivers as well
+!
+
+! get source information
+ print *,'reading position of the source from the CMTSOLUTION file'
+ call get_cmt(yr,jda,ho,mi,sec,tshift_cmt,hdur,lat,long,depth,moment_tensor, &
+ DT,1,min_tshift_cmt_original)
+
+! convert geographic latitude lat (degrees)
+! to geocentric colatitude theta (radians)
+ theta=PI/2.0d0-atan(0.99329534d0*tan(dble(lat(1))*PI/180.0d0))
+ phi=dble(long(1))*PI/180.0d0
+ call reduce(theta,phi)
+
+! compute Cartesian position of the source (ignore ellipticity for AVS_DX)
+! the point for the source is put at the surface for clarity (depth ignored)
+! even slightly above to superimpose to real surface
+ r_target_source = 1.02d0
+ x_target_source = r_target_source*sin(theta)*cos(phi)
+ y_target_source = r_target_source*sin(theta)*sin(phi)
+ z_target_source = r_target_source*cos(theta)
+
+! save triangle for AVS or DX representation of epicenter
+ r_target_source = 1.05d0
+ delta_trgl = 1.8 * pi / 180.
+ x_source_trgl1 = r_target_source*sin(theta+delta_trgl)*cos(phi-delta_trgl)
+ y_source_trgl1 = r_target_source*sin(theta+delta_trgl)*sin(phi-delta_trgl)
+ z_source_trgl1 = r_target_source*cos(theta+delta_trgl)
+
+ x_source_trgl2 = r_target_source*sin(theta+delta_trgl)*cos(phi+delta_trgl)
+ y_source_trgl2 = r_target_source*sin(theta+delta_trgl)*sin(phi+delta_trgl)
+ z_source_trgl2 = r_target_source*cos(theta+delta_trgl)
+
+ x_source_trgl3 = r_target_source*sin(theta-delta_trgl)*cos(phi)
+ y_source_trgl3 = r_target_source*sin(theta-delta_trgl)*sin(phi)
+ z_source_trgl3 = r_target_source*cos(theta-delta_trgl)
+
+ ntotpoinAVS_DX = 2
+ ntotspecAVS_DX = 1
+
+ print *
+ print *,'reading position of the receivers'
+
+! get number of stations from receiver file
+ open(unit=11,file='DATA/STATIONS',iostat=ios,status='old',action='read')
+ nrec = 0
+ do while(ios == 0)
+ read(11,"(a)",iostat=ios) dummystring
+ if(ios == 0) nrec = nrec + 1
+ enddo
+ close(11)
+
+ print *,'There are ',nrec,' three-component stations'
+ print *
+ if(nrec < 1) stop 'incorrect number of stations read - need at least one'
+
+ allocate(station_name(nrec))
+ allocate(network_name(nrec))
+ allocate(stlat(nrec))
+ allocate(stlon(nrec))
+ allocate(stele(nrec))
+ allocate(stbur(nrec))
+
+ allocate(x_target(nrec))
+ allocate(y_target(nrec))
+ allocate(z_target(nrec))
+
+! loop on all the stations
+ open(unit=11,file='DATA/STATIONS',status='old',action='read')
+ do irec=1,nrec
+ read(11,*) station_name(irec),network_name(irec),stlat(irec),stlon(irec),stele(irec),stbur(irec)
+
+! 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 the Cartesian position of the receiver (ignore ellipticity for AVS_DX)
+! points for the receivers are put at the surface for clarity (depth ignored)
+ r_target=1.0d0
+ x_target(irec) = r_target*dsin(theta)*dcos(phi)
+ y_target(irec) = r_target*dsin(theta)*dsin(phi)
+ z_target(irec) = r_target*dcos(theta)
+
+ enddo
+
+ close(11)
+
+! duplicate source to have right color normalization in AVS_DX
+ ntotpoinAVS_DX = ntotpoinAVS_DX + 2*nrec + 1
+ ntotspecAVS_DX = ntotspecAVS_DX + nrec + 1
+
+! write AVS or DX header with element data
+! add source and receivers (small AVS or DX lines)
+! duplicate source to have right color normalization in AVS_DX
+ if(USE_OPENDX) then
+ open(unit=11,file=trim(OUTPUT_FILES)//'/DX_source_receivers.dx',status='unknown')
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ntotpoinAVS_DX,' data follows'
+ write(11,*) sngl(x_target_source),' ',sngl(y_target_source),' ',sngl(z_target_source)
+ write(11,*) sngl(x_target_source+0.1*small_offset_source),' ', &
+ sngl(y_target_source+0.1*small_offset_source),' ',sngl(z_target_source+0.1*small_offset_source)
+ write(11,*) sngl(x_target_source+1.3*small_offset_source),' ', &
+ sngl(y_target_source+1.3*small_offset_source),' ',sngl(z_target_source+1.3*small_offset_source)
+ do ir=1,nrec
+ write(11,*) sngl(x_target(ir)),' ',sngl(y_target(ir)),' ',sngl(z_target(ir))
+ write(11,*) sngl(x_target(ir)+small_offset_receiver),' ', &
+ sngl(y_target(ir)+small_offset_receiver),' ',sngl(z_target(ir)+small_offset_receiver)
+ enddo
+ write(11,*) 'object 2 class array type int rank 1 shape 2 items ',ntotspecAVS_DX,' data follows'
+ write(11,*) '0 1'
+ do ir=1,nrec
+ write(11,*) 4+2*(ir-1)-1,' ',4+2*(ir-1)
+ enddo
+ write(11,*) '0 2'
+ write(11,*) 'attribute "element type" string "lines"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
+ write(11,*) '1.'
+ do ir=1,nrec
+ write(11,*) ' 255.'
+ enddo
+ write(11,*) ' 120.'
+ write(11,*) 'attribute "dep" string "connections"'
+ write(11,*) 'object "irregular connections irregular positions" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+ close(11)
+ else
+ open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_source_receivers.inp',status='unknown')
+ write(11,*) ntotpoinAVS_DX,' ',ntotspecAVS_DX,' 0 1 0'
+ write(11,*) '1 ',sngl(x_target_source),' ',sngl(y_target_source),' ',sngl(z_target_source)
+ write(11,*) '2 ',sngl(x_target_source+0.1*small_offset_source),' ', &
+ sngl(y_target_source+0.1*small_offset_source),' ',sngl(z_target_source+0.1*small_offset_source)
+ write(11,*) '3 ',sngl(x_target_source+1.3*small_offset_source),' ', &
+ sngl(y_target_source+1.3*small_offset_source),' ',sngl(z_target_source+1.3*small_offset_source)
+ do ir=1,nrec
+ write(11,*) 4+2*(ir-1),' ',sngl(x_target(ir)),' ',sngl(y_target(ir)),' ',sngl(z_target(ir))
+ write(11,*) 4+2*(ir-1)+1,' ',sngl(x_target(ir)+small_offset_receiver),' ', &
+ sngl(y_target(ir)+small_offset_receiver),' ',sngl(z_target(ir)+small_offset_receiver)
+ enddo
+ write(11,*) '1 1 line 1 2'
+ do ir=1,nrec
+ write(11,*) ir+1,' 1 line ',4+2*(ir-1),' ',4+2*(ir-1)+1
+ enddo
+ write(11,*) ir+1,' 1 line 1 3'
+ write(11,*) '1 1'
+ write(11,*) 'Zcoord, meters'
+ write(11,*) '1 1.'
+ do ir=1,nrec
+ write(11,*) ir+1,' 255.'
+ enddo
+ write(11,*) ir+1,' 120.'
+ close(11)
+ endif
+
+! create a file with the epicenter only, represented as a triangle
+
+! write AVS or DX header with element data
+ if(USE_OPENDX) then
+ open(unit=11,file=trim(OUTPUT_FILES)//'/DX_epicenter.dx',status='unknown')
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items 3 data follows'
+ write(11,*) sngl(x_source_trgl1),' ',sngl(y_source_trgl1),' ',sngl(z_source_trgl1)
+ write(11,*) sngl(x_source_trgl2),' ',sngl(y_source_trgl2),' ',sngl(z_source_trgl2)
+ write(11,*) sngl(x_source_trgl3),' ',sngl(y_source_trgl3),' ',sngl(z_source_trgl3)
+ write(11,*) 'object 2 class array type int rank 1 shape 3 items 1 data follows'
+ write(11,*) '0 1 2'
+ write(11,*) 'attribute "element type" string "triangles"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items 1 data follows'
+ write(11,*) '1.'
+ write(11,*) 'attribute "dep" string "connections"'
+ write(11,*) 'object "irregular connections irregular positions" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+ close(11)
+ else
+ open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_epicenter.inp',status='unknown')
+ write(11,*) '3 1 0 1 0'
+ write(11,*) '1 ',sngl(x_source_trgl1),' ',sngl(y_source_trgl1),' ',sngl(z_source_trgl1)
+ write(11,*) '2 ',sngl(x_source_trgl2),' ',sngl(y_source_trgl2),' ',sngl(z_source_trgl2)
+ write(11,*) '3 ',sngl(x_source_trgl3),' ',sngl(y_source_trgl3),' ',sngl(z_source_trgl3)
+ write(11,*) '1 1 tri 1 2 3'
+ write(11,*) '1 1'
+ write(11,*) 'Zcoord, meters'
+ write(11,*) '1 1.'
+ close(11)
+ endif
+
+ end program combine_AVS_DX
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_paraview_strain_data.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/combine_paraview_strain_data.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_paraview_strain_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_paraview_strain_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,303 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! A signed non-commercial agreement is required to use this program.
+! Please check http://www.gps.caltech.edu/research/jtromp for details.
+! Free for non-commercial academic research ONLY.
+! This program is distributed WITHOUT ANY WARRANTY whatsoever.
+! Do not redistribute this program without written permission.
+!
+!=====================================================================
+
+program combine_paraview_movie_data
+
+! combines the database files on several slices.
+! the local database file needs to have been collected onto the frontend (copy_local_database.pl)
+
+ implicit none
+
+ include 'constants.h'
+ include 'OUTPUT_FILES/values_from_mesher.h'
+
+ integer fid,i,ipoint, ios, it,itstart,itstop,dit_movie
+ integer iproc, num_node, npoint_all, nelement_all
+ integer np, ne, npoint(1000), nelement(1000), n1, n2, n3, n4, n5, n6, n7, n8
+
+ integer numpoin,nelement_local
+! real(kind=CUSTOM_REAL),dimension(NGLOBMAX_CRUST_MANTLE) :: xstore, ystore, zstore,datstore
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: xstore, ystore, zstore,datstore
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: SEEstore,SNNstore,SZZstore,SNEstore,SNZstore,SEZstore
+ real(kind=CUSTOM_REAL) :: x, y, z, dat
+ character(len=150) :: arg(7), prname, dimension_file
+ character(len=150) :: mesh_file, local_element_file, local_data_file
+ character(len=3) :: comp
+ logical :: MOVIE_COARSE
+
+ do i = 1,6
+ call getarg(i,arg(i))
+ if (i < 7 .and. trim(arg(i)) == '') then
+ print *, ' '
+ print *, ' Usage: xcombine_data nnodes dt_movie itstart itstop comp MOVIE_COARSE'
+ print *, ' component can be SEE, SNE,SEZ,SNN,SNZ,SZZ,I1 or I2'
+ print *, ' stored in the local directory as real(kind=CUSTOM_REAL) filename(NGLLX,NGLLY,NGLLZ,nspec) '
+ print *, 'MOVIE_COARSE = 0 or 1 '
+ stop ' Reenter command line options'
+ endif
+ enddo
+
+
+ read(arg(1),*) num_node
+ read(arg(2),*) dit_movie
+ read(arg(3),*) itstart
+ read(arg(4),*) itstop
+ read(arg(5),*) comp
+ read(arg(6),*) MOVIE_COARSE
+
+ if(num_node>1000) stop 'change array sizes for num_node > 1000 and recompile xcombine_paraview_movie_data'
+
+ print *, 'Number of nodes: ',num_node
+ print *, ' '
+ print *, 'Timeframes every ',dit_movie,'from: ',itstart,' to:',itstop
+
+ ! figure out total number of points
+ print *, 'Counting points'
+ do iproc = 1, num_node
+
+
+ ! print *, 'Counting elements: slice ', iproc-1
+ write(prname,'(a,i6.6,a)') 'proc',iproc-1,'_'
+
+ dimension_file = trim(prname) //'movie3D_info.txt'
+! print *, 'reading: ',trim(dimension_file)
+ open(unit = 27,file = trim(dimension_file),status='old',action='read', iostat = ios)
+ if (ios /= 0) stop 'Error opening file'
+
+ read(27,*) npoint(iproc),nelement(iproc)
+ close(27)
+
+ enddo
+
+ npoint_all = sum(npoint(1:num_node))
+ nelement_all = sum(nelement(1:num_node))
+ print *, 'Total number of points = ', npoint_all
+ print *, 'Total number of elements = ', nelement_all
+
+
+ do it = itstart, itstop, dit_movie
+ print *, '----------- Timeframe ', it, '----------------'
+
+ ! open paraview output mesh file
+ write(mesh_file,'(a,a,a,i6.6,a)') 'movie3D_',trim(comp),'_it',it,'.mesh'
+ call open_file_fd(trim(mesh_file)//char(0),fid)
+
+ np = 0
+
+ ! write point and scalar information
+ print *,'writing point information'
+ do iproc = 1, num_node
+
+
+ ! print *, ' '
+ !print *, 'Writing points: slice ', iproc-1,'npoints',npoint(iproc)
+ write(prname,'(a,i6.6,a)') 'proc',iproc-1,'_'
+
+ numpoin = 0
+
+
+ if (iproc == 1) then
+ call write_integer_fd(fid,npoint_all)
+ endif
+
+ open(unit = 27,file = trim(prname)//'movie3D_x.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) stop 'Error opening file x.bin'
+ if (npoint(iproc)>0) then
+ read(27) xstore(1:npoint(iproc))
+ endif
+ close(27)
+
+ open(unit = 27,file = trim(prname)//'movie3D_y.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) stop 'Error opening file y.bin'
+ if (npoint(iproc)>0) then
+ read(27) ystore(1:npoint(iproc))
+ endif
+ close(27)
+
+ open(unit = 27,file = trim(prname)//'movie3D_z.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) stop 'Error opening file z.bin'
+ if (npoint(iproc)>0) then
+ read(27) zstore(1:npoint(iproc))
+ endif
+ close(27)
+
+ if( (comp /= 'SI1') .and. (comp /= 'SI2')) then
+!comp == 'SEE' .or. comp == 'SNN' .or. comp == 'SZZ' .or. comp == 'SEZ' .or. comp == 'SNZ' .or. comp == 'SNE') then
+ write(local_data_file,'(a,a,i6.6,a)') 'movie3D_',comp,it,'.bin'
+
+ !print *,'reading comp:',trim(prname)//trim(local_data_file)
+
+ open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) stop 'Error opening file it.bin'
+ if (npoint(iproc)>0) then
+ read(27) datstore(1:npoint(iproc))
+ endif
+ close(27)
+ elseif(comp == 'SI1' .or. comp == 'SI2') then
+ write(local_data_file,'(a,i6.6,a)') 'movie3D_SEE',it,'.bin'
+ !print *, iproc,'reading from file:'//trim(prname)//trim(local_data_file)
+ !print *, 'reading from file:',local_data_file
+ open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) stop 'Error opening file it.bin'
+ if (npoint(iproc)>0) then
+ read(27) SEEstore(1:npoint(iproc))
+ endif
+ close(27)
+
+ write(local_data_file,'(a,i6.6,a)') 'movie3D_SNE',it,'.bin'
+ !print *, 'reading from file:',local_data_file
+ open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) stop 'Error opening file it.bin'
+ if (npoint(iproc)>0) then
+ read(27) SNEstore(1:npoint(iproc))
+ endif
+ close(27)
+
+ write(local_data_file,'(a,i6.6,a)') 'movie3D_SEZ',it,'.bin'
+ !print *, 'reading from file:',local_data_file
+ open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) stop 'Error opening file it.bin'
+ if (npoint(iproc)>0) then
+ read(27) SEZstore(1:npoint(iproc))
+ endif
+ close(27)
+
+ write(local_data_file,'(a,i6.6,a)') 'movie3D_SNN',it,'.bin'
+ !print *, 'reading from file:',local_data_file
+ open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) stop 'Error opening file it.bin'
+ if (npoint(iproc)>0) then
+ read(27) SNNstore(1:npoint(iproc))
+ endif
+ close(27)
+
+ write(local_data_file,'(a,i6.6,a)') 'movie3D_SNZ',it,'.bin'
+ !print *, 'reading from file:',local_data_file
+ open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) stop 'Error opening file it.bin'
+ if (npoint(iproc)>0) then
+ read(27) SNZstore(1:npoint(iproc))
+ endif
+ close(27)
+
+ write(local_data_file,'(a,i6.6,a)') 'movie3D_SZZ',it,'.bin'
+ !print *, 'reading from file:',local_data_file
+ open(unit = 27,file = trim(prname)//trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) stop 'Error opening file it.bin'
+ if (npoint(iproc)>0) then
+ read(27) SZZstore(1:npoint(iproc))
+ endif
+ close(27)
+ else
+ stop 'unrecognized component'
+ endif !strain or invariant
+
+ datstore=datstore
+ do ipoint=1,npoint(iproc)
+ numpoin = numpoin + 1
+ x = xstore(ipoint)
+ y = ystore(ipoint)
+ z = zstore(ipoint)
+ dat = datstore(ipoint)
+ call write_real_fd(fid,x)
+ call write_real_fd(fid,y)
+ call write_real_fd(fid,z)
+ call write_real_fd(fid,dat)
+ ! print *, 'point:',ipoint,x,y,z,dat
+ enddo !
+
+ if (numpoin /= npoint(iproc)) stop 'different number of points'
+ np = np + npoint(iproc)
+
+ enddo ! all slices for points
+
+ if (np /= npoint_all) stop 'Error: Number of total points are not consistent'
+ print *, 'Total number of points: ', np
+ print *, ' '
+
+ ne = 0
+! write element information
+ print *, 'Writing element information'
+ do iproc = 1, num_node
+
+ ! print *, 'Reading slice ', iproc-1
+ write(prname,'(a,i6.6,a)') 'proc',iproc-1,'_'
+
+ if (iproc == 1) then
+ np = 0
+ else
+ np = sum(npoint(1:iproc-1))
+ endif
+
+
+ local_element_file = trim(prname) // 'movie3D_elements.bin'
+ open(unit = 27, file = trim(local_element_file), status = 'old', action='read',iostat = ios,form='unformatted')
+ if (ios /= 0) stop 'Error opening file'
+
+ ! print *, trim(local_element_file)
+
+ if (iproc == 1) then
+ if(MOVIE_COARSE) then
+ call write_integer_fd(fid,nelement_all)
+ else
+ call write_integer_fd(fid,nelement_all*64)
+ endif
+ endif
+
+ if(MOVIE_COARSE) then
+ nelement_local = nelement(iproc)
+ else
+ nelement_local = nelement(iproc)*64
+ endif
+ do i = 1, nelement_local
+ read(27) n1, n2, n3, n4, n5, n6, n7, n8
+ n1 = n1+np
+ n2 = n2+np
+ n3 = n3+np
+ n4 = n4+np
+ n5 = n5+np
+ n6 = n6+np
+ n7 = n7+np
+ n8 = n8+np
+ call write_integer_fd(fid,n1)
+ call write_integer_fd(fid,n2)
+ call write_integer_fd(fid,n3)
+ call write_integer_fd(fid,n4)
+ call write_integer_fd(fid,n5)
+ call write_integer_fd(fid,n6)
+ call write_integer_fd(fid,n7)
+ call write_integer_fd(fid,n8)
+ !write(*,*) n1, n2, n3, n4, n5, n6, n7, n8
+ enddo
+ close(27)
+
+ ne = ne + nelement(iproc)
+
+ enddo ! num_node
+ print *, 'Total number of elements: ', ne,' nelement_all',nelement_all
+ if (ne /= nelement_all) stop 'Number of total elements are not consistent'
+
+ call close_file_fd(fid)
+
+ print *, 'Done writing '//trim(mesh_file)
+ print *, ' '
+
+ enddo ! timesteps
+ print *, ' '
+
+end program combine_paraview_movie_data
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_surf_data.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/combine_surf_data.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_surf_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_surf_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,349 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+program combine_surf_data
+
+ ! combines the database files on several slices.
+
+ implicit none
+
+ include 'constants.h'
+ include 'OUTPUT_FILES/values_from_mesher.h'
+
+ integer,parameter :: MAX_NUM_NODES = 400
+
+ integer i,j,k,ispec_surf,ios,it,num_node,njunk,ires,idim,iproc,njunk1,njunk2,njunk3,inx,iny
+ character(len=150) :: arg(20),sline,filename,surfname,reg_name,belm_name, indir, outdir
+ character(len=150) :: mesh_file, pt_mesh_file, em_mesh_file, command_name
+ logical :: HIGH_RESOLUTION_MESH,FILE_ARRAY_IS_3D
+ integer :: node_list(MAX_NUM_NODES),nspec(MAX_NUM_NODES),nglob(MAX_NUM_NODES)
+
+ character(len=150) :: prname,dimen_name,prname2,nspec2D_file,dimension_file
+ character(len=150) :: ibelm_surf_file,data_file,ibool_file
+ integer :: nspec2D_moho_val, nspec2D_400_val, nspec2D_670_val, nspec_surf
+ integer :: npoint,nelement, npoint_total,nelement_total, pfd,efd, np, ne, numpoin
+ integer, allocatable :: ibelm_surf(:)
+ real(kind=CUSTOM_REAL), allocatable :: data_2D(:,:,:), data_3D(:,:,:,:)
+ integer ibool(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),num_ibool(NGLOB_CRUST_MANTLE)
+ real(kind=CUSTOM_REAL),dimension(NGLOB_CRUST_MANTLE) :: xstore, ystore, zstore
+ logical mask_ibool(NGLOB_CRUST_MANTLE)
+ real dat, x, y, z
+ integer ispec, iglob, iglob1, iglob2, iglob3, iglob4, n1, n2, n3, n4, nex
+
+
+! ------------------ program starts here -------------------
+
+ do i = 1, 7
+ call getarg(i,arg(i))
+ if (i < 7 .and. trim(arg(i)) == '') then
+ write(*,*) ' '
+ write(*,*) ' Usage: xcombine_surf_data slice_list filename surfname input_dir output_dir high/low-resolution 2D/3D'
+ write(*,*) ' filename.bin can be either'
+ write(*,*) ' real(kind=CUSTOM_REAL) filename(NGLLX,NGLLY,NGLLZ,nspec)'
+ write(*,*) ' or --- filename(NGLLX,NGLLY,NSPEC2D) where'
+ write(*,*) ' filename=moho_kernel, d400_kernel, d670_kernel, CMB_kernel, or ICB_kernel'
+ write(*,*) ' possible surface names: Moho, 400, 670, CMB, ICB'
+ write(*,*) ' files have been collected in input_dir, output mesh file goes to output_dir '
+ write(*,*) ' give 0 for low resolution and 1 for high resolution'
+ write(*,*) ' give 0 for 2D and 1 for 3D filenames'
+ write(*,*) ' region does not have to be specified'
+ stop ' Reenter command line options'
+ endif
+ enddo
+
+ if (NSPEC_CRUST_MANTLE < NSPEC_OUTER_CORE .or. NSPEC_CRUST_MANTLE < NSPEC_INNER_CORE) &
+ stop 'This program needs that NSPEC_CRUST_MANTLE > NSPEC_OUTER_CORE and NSPEC_INNER_CORE'
+
+ ! get slice list
+ num_node = 0
+ open(unit = 20, file = trim(arg(1)), status = 'unknown',iostat = ios)
+ if (ios /= 0) stop 'Error opening file'
+ do while (1 == 1)
+ read(20,'(a)',iostat=ios) sline
+ if (ios /= 0) exit
+ read(sline,*,iostat=ios) njunk
+ if (ios /= 0) exit
+ num_node = num_node + 1
+ node_list(num_node) = njunk
+ enddo
+ close(20)
+ print *, 'Slice list: '
+ print *, node_list(1:num_node)
+ print *, ' '
+
+ filename = arg(2)
+
+ ! discontinutity surfaces
+ surfname = arg(3)
+ if (trim(surfname) == 'Moho' .or. trim(surfname) == '400' .or. trim(surfname) == '670') then
+ reg_name = 'reg1_'
+ belm_name = trim(reg_name)//'boundary_disc.bin'
+ else if (trim(surfname) == 'CMB') then ! assume CMB_top
+ reg_name = 'reg1_'
+ belm_name = trim(reg_name)//'boundary.bin' ! use reg2_ibelm for CMB_bot
+ else if (trim(surfname) == 'ICB') then ! assume ICB_top
+ reg_name = 'reg2_'
+ belm_name = trim(reg_name)//'boundary.bin' ! use reg3_ibelm for ICB_bot
+ else
+ stop 'surfname type can only be: Moho, 400, 670, CMB, and ICB'
+ endif
+
+ ! input and output dir
+ indir= arg(4)
+ outdir = arg(5)
+
+ ! resolution
+ read(arg(6),*) ires
+ if (ires == 0) then
+ HIGH_RESOLUTION_MESH = .false.
+ inx = NGLLX-1; iny = NGLLY-1
+ else
+ HIGH_RESOLUTION_MESH = .true.
+ inx = 1; iny = 1
+ endif
+
+ ! file dimension
+ read(arg(7),*) idim
+ if (idim == 0) then
+ FILE_ARRAY_IS_3D = .false.
+ else
+ FILE_ARRAY_IS_3D = .true.
+ endif
+
+ dimen_name = trim(reg_name)//'array_dims.txt'
+
+ ! figure out the total number of points/elements and allocate arrays
+ write(prname,'(a,i6.6,a)') trim(indir)//'/proc',node_list(1),'_'
+ nspec2D_file = trim(prname) // trim(belm_name)
+
+ open(27,file=trim(nspec2D_file),status='old',form='unformatted')
+ if (trim(surfname) == 'CMB' .or. trim(surfname) == 'ICB') then
+ read(27) njunk
+ read(27) njunk
+ read(27) njunk
+ read(27) njunk
+ read(27) nspec_surf
+ else
+ read(27) nspec2D_moho_val,nspec2D_400_val,nspec2D_670_val
+ if (trim(surfname) == 'Moho') nspec_surf = nspec2D_moho_val
+ if (trim(surfname) == '400') nspec_surf = nspec2D_400_val
+ if (trim(surfname) == '670') nspec_surf = nspec2D_670_val
+ endif
+ close(27)
+ nex = int(dsqrt(nspec_surf*1.0d0))
+ if (HIGH_RESOLUTION_MESH) then
+ npoint = (nex*(NGLLX-1)+1) * (nex*(NGLLY-1)+1)
+ nelement = nspec_surf * (NGLLX-1) * (NGLLY-1)
+ else
+ npoint = (nex+1) * (nex+1)
+ nelement = nspec_surf
+ endif
+ npoint_total = npoint * num_node
+ nelement_total = nelement * num_node
+ print *, 'total number of spectral elements = ', nspec_surf
+ print *, 'total number of points = ', npoint_total
+ print *, 'total number of elements = ', nelement_total
+
+ ! ========= write points and elements files ===================
+ allocate(ibelm_surf(nspec_surf))
+ do it = 1, num_node
+ write(prname,'(a,i6.6,a)') trim(indir)//'/proc',node_list(it),'_'
+ dimension_file = trim(prname) // trim(dimen_name)
+ open(unit=27,file=trim(dimension_file),status='old',action='read', iostat = ios)
+ if (ios /= 0) stop 'Error opening file'
+ read(27,*) nspec(it)
+ read(27,*) nglob(it)
+ close(27)
+ enddo
+
+ if ( .not. FILE_ARRAY_IS_3D) then
+ allocate(data_2D(NGLLX,NGLLY,nspec_surf))
+ else
+ allocate(data_3D(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE))
+ endif
+
+ ! open paraview output mesh file
+ write(mesh_file,'(a,i1,a)') trim(outdir)//'/'//trim(filename)//'.surf'
+ write(pt_mesh_file,'(a,i1,a)') trim(outdir)//'/'//trim(filename)//'_point.surf'
+ write(em_mesh_file,'(a,i1,a)') trim(outdir)//'/'//trim(filename)//'_element.surf'
+ command_name='rm -f '//trim(pt_mesh_file)//' '//trim(em_mesh_file)//' '//trim(mesh_file)
+
+ call system(trim(command_name))
+ call open_file_fd(trim(pt_mesh_file)//char(0),pfd)
+ call open_file_fd(trim(em_mesh_file)//char(0),efd)
+
+ np = 0
+ ne = 0
+ call write_integer_fd(pfd,npoint_total)
+ call write_integer_fd(efd,nelement_total)
+
+ ! loop over slices
+
+ do it = 1, num_node
+
+ iproc = node_list(it)
+
+ print *, 'Reading slice ', iproc
+ write(prname,'(a,i6.6,a)') trim(indir)//'/proc',iproc,'_'
+ prname2 = trim(prname)//trim(reg_name)
+
+ ! surface topology file
+ ibelm_surf_file = trim(prname) // trim(belm_name)
+ print *, trim(ibelm_surf_file)
+ open(unit = 28,file = trim(ibelm_surf_file),status='old', iostat = ios, form='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(ibelm_surf_file); stop
+ endif
+ if (trim(surfname) == 'Moho' .or. trim(surfname) == '400' .or. trim(surfname) == '670') then
+ read(28) njunk1,njunk2,njunk3
+ if (trim(surfname) == 'Moho') then;
+ read(28) ibelm_surf ! moho top
+ else if (trim(surfname) == '400' .or. trim(surfname) == '670') then
+ read(28) njunk ! moho top
+ read(28) njunk ! moho bot
+ if (trim(surfname) == '400') then
+ read(28) ibelm_surf ! 400 top
+ else
+ read(28) njunk ! 400 top
+ read(28) njunk ! 400 bot
+ read(28) ibelm_surf ! 670 top
+ endif
+ endif
+ else ! CMB or ICB
+ read(28) njunk; read(28) njunk; read(28) njunk; read(28) njunk; read(28) njunk; read(28) njunk;
+ read(28) njunk; read(28) njunk; read(28) njunk; read(28) njunk
+ read(28) ibelm_surf
+ endif
+ close(28)
+
+ ! datafile
+ data_file = trim(prname2)//trim(filename)//'.bin'
+ print *, trim(data_file)
+ open(unit = 27,file = trim(data_file),status='old', iostat = ios,form ='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(data_file); stop
+ endif
+ if (FILE_ARRAY_IS_3D) then
+ read(27) data_3D(:,:,:,1:nspec(it))
+ else
+ read(27) data_2D
+ endif
+ close(27)
+
+ ! ibool file
+ ibool_file = trim(prname2) // 'solver_data_2' // '.bin'
+ print *, trim(ibool_file)
+ open(unit = 28,file = trim(ibool_file),status='old', iostat = ios, form='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(ibool_file); stop
+ endif
+ read(28) xstore(1:nglob(it))
+ read(28) ystore(1:nglob(it))
+ read(28) zstore(1:nglob(it))
+ read(28) ibool(:,:,:,1:nspec(it))
+ close(28)
+
+ mask_ibool(:) = .false.
+ num_ibool(:) = 0
+ numpoin = 0
+ k = 1
+ do ispec_surf=1,nspec_surf
+ ispec = ibelm_surf(ispec_surf)
+ do j = 1, NGLLY, iny
+ do i = 1, NGLLX, inx
+ iglob = ibool(i,j,k,ispec)
+ if(.not. mask_ibool(iglob)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob)
+ y = ystore(iglob)
+ z = zstore(iglob)
+ call write_real_fd(pfd,x)
+ call write_real_fd(pfd,y)
+ call write_real_fd(pfd,z)
+ if (FILE_ARRAY_IS_3D) then
+ dat=data_3D(i,j,k,ispec)
+ else
+ dat=data_2D(i,j,ispec_surf)
+ endif
+ call write_real_fd(pfd,dat)
+! call write_real_fd(pfd,real(ispec_surf))
+ mask_ibool(iglob) = .true.
+ num_ibool(iglob) = numpoin
+ endif
+ enddo ! i
+ enddo ! j
+ enddo !ispec_surf
+ if (numpoin /= npoint) stop 'Error: number of points are not consistent'
+
+ ! write element info
+ do ispec_surf = 1, nspec_surf
+ ispec = ibelm_surf(ispec_surf)
+ do j = 1, NGLLY-1, iny
+ do i = 1, NGLLX-1, inx
+ iglob1 = ibool(i,j,k,ispec)
+ iglob2 = ibool(i+inx,j,k,ispec)
+ iglob3 = ibool(i+inx,j+iny,k,ispec)
+ iglob4 = ibool(i,j+iny,k,ispec)
+
+ n1 = num_ibool(iglob1)+np-1
+ n2 = num_ibool(iglob2)+np-1
+ n3 = num_ibool(iglob3)+np-1
+ n4 = num_ibool(iglob4)+np-1
+
+ call write_integer_fd(efd,n1)
+ call write_integer_fd(efd,n2)
+ call write_integer_fd(efd,n3)
+ call write_integer_fd(efd,n4)
+
+ ne = ne + 1
+
+ enddo
+ enddo
+ enddo
+
+ np = np + numpoin
+
+ enddo ! all slices for points
+
+ if (np /= npoint_total) stop 'Error: Number of total points not consistent'
+ if (ne /= nelement_total) stop 'Error: Number of total elements not consistent'
+
+ call close_file_fd(pfd)
+ call close_file_fd(efd)
+
+ ! cat files
+ command_name='cat '//trim(pt_mesh_file)//' '//trim(em_mesh_file)//' > '//trim(mesh_file)
+ print *, ' '
+ print *, 'cat mesh files ...'
+ print *, trim(command_name)
+ call system(trim(command_name))
+
+ print *, 'Done writing '//trim(mesh_file)
+ print *, ' '
+
+end program combine_surf_data
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_vol_data.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/combine_vol_data.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_vol_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/combine_vol_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,999 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+program combine_vol_data
+
+ ! combines the database files on several slices.
+ ! the local database file needs to have been collected onto the frontend (copy_local_database.pl)
+
+ implicit none
+
+ include 'constants.h'
+ include 'OUTPUT_FILES/values_from_mesher.h'
+
+ integer,parameter :: MAX_NUM_NODES = 1000
+ integer iregion, ir, irs, ire, ires, pfd, efd
+ character(len=256) :: sline, arg(7), filename, in_topo_dir, in_file_dir, outdir
+ character(len=256) :: prname_topo, prname_file, dimension_file
+ character(len=1038) :: command_name
+ character(len=256) :: pt_mesh_file1, pt_mesh_file2, mesh_file, em_mesh_file, data_file, topo_file
+ integer, dimension(MAX_NUM_NODES) :: node_list, nspec, nglob, npoint, nelement
+ integer iproc, num_node, i,j,k,ispec, ios, it, di, dj, dk
+ integer np, ne, njunk
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: data
+ real(kind=CUSTOM_REAL),dimension(NGLOB_CRUST_MANTLE) :: xstore, ystore, zstore
+ integer ibool(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE)
+ integer num_ibool(NGLOB_CRUST_MANTLE)
+ logical mask_ibool(NGLOB_CRUST_MANTLE), HIGH_RESOLUTION_MESH
+ real x, y, z, dat
+ integer numpoin, iglob, n1, n2, n3, n4, n5, n6, n7, n8
+ integer iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
+
+ ! instead of taking the first value which appears for a global point, average the values
+ ! if there are more than one gll points for a global point (points on element corners, edges, faces)
+ logical,parameter:: AVERAGE_GLOBALPOINTS = .false.
+ integer:: ibool_count(NGLOB_CRUST_MANTLE)
+ real(kind=CUSTOM_REAL):: ibool_dat(NGLOB_CRUST_MANTLE)
+
+ ! note:
+ ! if one wants to remove the topography and ellipticity distortion, you would run the mesher again
+ ! but turning the flags: TOPOGRAPHY and ELLIPTICITY to .false.
+ ! then, use those as topo files: proc***_array_dims.txt and proc***_solver_data_2.bin
+ ! of course, this would also work by just turning ELLIPTICITY to .false. so that the CORRECT_ELLIPTICITY below
+ ! becomes unneccessary
+ !
+ ! puts point locations back into a perfectly spherical shape by removing the ellipticity factor;
+ ! useful for plotting spherical cuts at certain depths
+ logical,parameter:: CORRECT_ELLIPTICITY = .false.
+ integer :: nspl
+ double precision :: rspl(NR),espl(NR),espl2(NR)
+ logical,parameter :: ONE_CRUST = .false. ! if you want to correct a model with one layer only in PREM crust
+
+
+ ! starts here--------------------------------------------------------------------------------------------------
+ do i = 1, 7
+ call getarg(i,arg(i))
+ if (i < 7 .and. trim(arg(i)) == '') then
+ print *, ' '
+ print *, ' Usage: xcombine_vol_data slice_list filename input_topo_dir input_file_dir '
+ print *, ' output_dir high/low-resolution [region]'
+ print *, ' ***** Notice: now allow different input dir for topo and kernel files ******** '
+ print *, ' expect to have the topology and filename.bin(NGLLX,NGLLY,NGLLZ,nspec) '
+ print *, ' already collected to input_topo_dir and input_file_dir'
+ print *, ' output mesh files (filename_points.mesh, filename_elements.mesh) go to output_dir '
+ print *, ' give 0 for low resolution and 1 for high resolution'
+ print *, ' if region is not specified, all 3 regions will be collected, otherwise, only collect regions specified'
+ stop ' Reenter command line options'
+ endif
+ enddo
+
+ if (NSPEC_CRUST_MANTLE < NSPEC_OUTER_CORE .or. NSPEC_CRUST_MANTLE < NSPEC_INNER_CORE) &
+ stop 'This program needs that NSPEC_CRUST_MANTLE > NSPEC_OUTER_CORE and NSPEC_INNER_CORE'
+
+ ! get region id
+ if (trim(arg(7)) == '') then
+ iregion = 0
+ else
+ read(arg(7),*) iregion
+ endif
+ if (iregion > 3 .or. iregion < 0) stop 'Iregion = 0,1,2,3'
+ if (iregion == 0) then
+ irs = 1
+ ire = 3
+ else
+ irs = iregion
+ ire = irs
+ endif
+
+ ! get slices id
+ num_node = 0
+ open(unit = 20, file = trim(arg(1)), status = 'old',iostat = ios)
+ if (ios /= 0) then
+ print*,'no file: ',trim(arg(1))
+ stop 'Error opening slices file'
+ endif
+
+ do while (1 == 1)
+ read(20,'(a)',iostat=ios) sline
+ if (ios /= 0) exit
+ read(sline,*,iostat=ios) njunk
+ if (ios /= 0) exit
+ num_node = num_node + 1
+ node_list(num_node) = njunk
+ enddo
+ close(20)
+ print *, 'slice list: '
+ print *, node_list(1:num_node)
+ print *, ' '
+
+ ! file to collect
+ filename = arg(2)
+
+ ! input and output dir
+ in_topo_dir= arg(3)
+ in_file_dir= arg(4)
+ outdir = arg(5)
+
+ ! resolution
+ read(arg(6),*) ires
+ if (ires == 0) then
+ HIGH_RESOLUTION_MESH = .false.
+ di = NGLLX-1; dj = NGLLY-1; dk = NGLLZ-1
+ else if( ires == 1 ) then
+ HIGH_RESOLUTION_MESH = .true.
+ di = 1; dj = 1; dk = 1
+ else if( ires == 2 ) then
+ HIGH_RESOLUTION_MESH = .false.
+ di = (NGLLX-1)/2.0; dj = (NGLLY-1)/2.0; dk = (NGLLZ-1)/2.0
+ endif
+ if( HIGH_RESOLUTION_MESH ) then
+ print *, ' high resolution ', HIGH_RESOLUTION_MESH
+ else
+ print *, ' low resolution ', HIGH_RESOLUTION_MESH
+ endif
+
+ ! sets up ellipticity splines in order to remove ellipticity from point coordinates
+ if( CORRECT_ELLIPTICITY ) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
+
+
+ do ir = irs, ire
+ print *, '----------- Region ', ir, '----------------'
+
+ ! open paraview output mesh file
+ write(pt_mesh_file1,'(a,i1,a)') trim(outdir)//'/' // 'reg_',ir,'_'//trim(filename)//'_point1.mesh'
+ write(pt_mesh_file2,'(a,i1,a)') trim(outdir)//'/' // 'reg_',ir,'_'//trim(filename)//'_point2.mesh'
+ write(mesh_file,'(a,i1,a)') trim(outdir)//'/' // 'reg_',ir,'_'//trim(filename)//'.mesh'
+ write(em_mesh_file,'(a,i1,a)') trim(outdir)//'/' // 'reg_',ir,'_'//trim(filename)//'_element.mesh'
+
+ call open_file_fd(trim(pt_mesh_file1)//char(0),pfd)
+ call open_file_fd(trim(em_mesh_file)//char(0),efd)
+
+ ! figure out total number of points and elements for high-res mesh
+
+ do it = 1, num_node
+
+ iproc = node_list(it)
+
+ print *, 'Reading slice ', iproc
+ write(prname_topo,'(a,i6.6,a,i1,a)') trim(in_topo_dir)//'/proc',iproc,'_reg',ir,'_'
+ write(prname_file,'(a,i6.6,a,i1,a)') trim(in_file_dir)//'/proc',iproc,'_reg',ir,'_'
+
+
+ dimension_file = trim(prname_topo) //'array_dims.txt'
+ open(unit = 27,file = trim(dimension_file),status='old',action='read', iostat = ios)
+ if (ios /= 0) then
+ print*,'error ',ios
+ print*,'file:',trim(dimension_file)
+ stop 'Error opening file'
+ endif
+
+ read(27,*) nspec(it)
+ read(27,*) nglob(it)
+ close(27)
+ if (HIGH_RESOLUTION_MESH) then
+ npoint(it) = nglob(it)
+ nelement(it) = nspec(it) * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1)
+ else if( ires == 0 ) then
+ nelement(it) = nspec(it)
+ else if (ires == 2 ) then
+ nelement(it) = nspec(it) * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1) / 8
+ endif
+
+ enddo
+
+ print *, 'nspec(it) = ', nspec(1:num_node)
+ print *, 'nglob(it) = ', nglob(1:num_node)
+
+ call write_integer_fd(efd,sum(nelement(1:num_node)))
+
+ np = 0
+ ne = 0
+
+ ! write points information
+ do it = 1, num_node
+
+ iproc = node_list(it)
+
+
+ print *, ' '
+ print *, 'Reading slice ', iproc
+ write(prname_topo,'(a,i6.6,a,i1,a)') trim(in_topo_dir)//'/proc',iproc,'_reg',ir,'_'
+ write(prname_file,'(a,i6.6,a,i1,a)') trim(in_file_dir)//'/proc',iproc,'_reg',ir,'_'
+
+ ! filename.bin
+ data_file = trim(prname_file) // trim(filename) // '.bin'
+ open(unit = 27,file = trim(data_file),status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) then
+ print*,'error ',ios
+ print*,'file:',trim(data_file)
+ stop 'Error opening file'
+ endif
+
+ data(:,:,:,:) = -1.e10
+ read(27) data(:,:,:,1:nspec(it))
+ close(27)
+
+ print *,trim(data_file)
+ print *,' min/max value: ',minval(data(:,:,:,1:nspec(it))),maxval(data(:,:,:,1:nspec(it)))
+ print *
+
+ ! topology file
+ topo_file = trim(prname_topo) // 'solver_data_2' // '.bin'
+ open(unit = 28,file = trim(topo_file),status='old',action='read', iostat = ios, form='unformatted')
+ if (ios /= 0) then
+ print*,'error ',ios
+ print*,'file:',trim(topo_file)
+ stop 'Error opening file'
+ endif
+ xstore(:) = 0.0
+ ystore(:) = 0.0
+ zstore(:) = 0.0
+ ibool(:,:,:,:) = -1
+ read(28) xstore(1:nglob(it))
+ read(28) ystore(1:nglob(it))
+ read(28) zstore(1:nglob(it))
+ read(28) ibool(:,:,:,1:nspec(it))
+ close(28)
+
+ print *, trim(topo_file)
+
+
+ !average data on global points
+ ibool_count(:) = 0
+ ibool_dat(:) = 0.0
+ if( AVERAGE_GLOBALPOINTS ) then
+ do ispec=1,nspec(it)
+ do k = 1, NGLLZ, dk
+ do j = 1, NGLLY, dj
+ do i = 1, NGLLX, di
+ iglob = ibool(i,j,k,ispec)
+
+ dat = data(i,j,k,ispec)
+
+ ibool_dat(iglob) = ibool_dat(iglob) + dat
+ ibool_count(iglob) = ibool_count(iglob) + 1
+ enddo
+ enddo
+ enddo
+ enddo
+ do iglob=1,nglob(it)
+ if( ibool_count(iglob) > 0 ) then
+ ibool_dat(iglob) = ibool_dat(iglob)/ibool_count(iglob)
+ endif
+ enddo
+ endif
+
+ mask_ibool(:) = .false.
+ num_ibool(:) = 0
+ numpoin = 0
+
+
+ ! write point file
+ do ispec=1,nspec(it)
+ do k = 1, NGLLZ, dk
+ do j = 1, NGLLY, dj
+ do i = 1, NGLLX, di
+ iglob = ibool(i,j,k,ispec)
+ if( iglob == -1 ) cycle
+
+ ! takes the averaged data value for mesh
+ if( AVERAGE_GLOBALPOINTS ) then
+ if(.not. mask_ibool(iglob)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob)
+ y = ystore(iglob)
+ z = zstore(iglob)
+
+ ! remove ellipticity
+ if( CORRECT_ELLIPTICITY ) call reverse_ellipticity(x,y,z,nspl,rspl,espl,espl2)
+
+ !dat = data(i,j,k,ispec)
+ dat = ibool_dat(iglob)
+
+ call write_real_fd(pfd,x)
+ call write_real_fd(pfd,y)
+ call write_real_fd(pfd,z)
+ call write_real_fd(pfd,dat)
+
+ mask_ibool(iglob) = .true.
+ num_ibool(iglob) = numpoin
+ endif
+ else
+ if(.not. mask_ibool(iglob)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob)
+ y = ystore(iglob)
+ z = zstore(iglob)
+
+ ! remove ellipticity
+ if( CORRECT_ELLIPTICITY ) call reverse_ellipticity(x,y,z,nspl,rspl,espl,espl2)
+
+ dat = data(i,j,k,ispec)
+ call write_real_fd(pfd,x)
+ call write_real_fd(pfd,y)
+ call write_real_fd(pfd,z)
+ call write_real_fd(pfd,dat)
+ mask_ibool(iglob) = .true.
+ num_ibool(iglob) = numpoin
+ endif
+ endif
+ enddo ! i
+ enddo ! j
+ enddo ! k
+ enddo !ispec
+
+ ! no way to check the number of points for low-res
+ if (HIGH_RESOLUTION_MESH .and. numpoin /= npoint(it)) then
+ print*,'region:',ir
+ print*,'error number of points:',numpoin,npoint(it)
+ stop 'different number of points (high-res)'
+ else if (.not. HIGH_RESOLUTION_MESH) then
+ npoint(it) = numpoin
+ endif
+
+ ! write elements file
+ do ispec = 1, nspec(it)
+ do k = 1, NGLLZ-1, dk
+ do j = 1, NGLLY-1, dj
+ do i = 1, NGLLX-1, di
+ iglob1 = ibool(i,j,k,ispec)
+ iglob2 = ibool(i+di,j,k,ispec)
+ iglob3 = ibool(i+di,j+dj,k,ispec)
+ iglob4 = ibool(i,j+dj,k,ispec)
+ iglob5 = ibool(i,j,k+dk,ispec)
+ iglob6 = ibool(i+di,j,k+dk,ispec)
+ iglob7 = ibool(i+di,j+dj,k+dk,ispec)
+ iglob8 = ibool(i,j+dj,k+dk,ispec)
+ n1 = num_ibool(iglob1)+np-1
+ n2 = num_ibool(iglob2)+np-1
+ n3 = num_ibool(iglob3)+np-1
+ n4 = num_ibool(iglob4)+np-1
+ n5 = num_ibool(iglob5)+np-1
+ n6 = num_ibool(iglob6)+np-1
+ n7 = num_ibool(iglob7)+np-1
+ n8 = num_ibool(iglob8)+np-1
+ call write_integer_fd(efd,n1)
+ call write_integer_fd(efd,n2)
+ call write_integer_fd(efd,n3)
+ call write_integer_fd(efd,n4)
+ call write_integer_fd(efd,n5)
+ call write_integer_fd(efd,n6)
+ call write_integer_fd(efd,n7)
+ call write_integer_fd(efd,n8)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ np = np + npoint(it)
+ ne = ne + nelement(it)
+
+ enddo ! all slices for points
+
+ if (np /= sum(npoint(1:num_node))) stop 'Error: Number of total points are not consistent'
+ if (ne /= sum(nelement(1:num_node))) stop 'Error: Number of total elements are not consistent'
+
+ print *, 'Total number of points: ', np
+ print *, 'Total number of elements: ', ne
+
+ call close_file_fd(pfd)
+ call close_file_fd(efd)
+
+ ! add the critical piece: total number of points
+ call open_file_fd(trim(pt_mesh_file2)//char(0),pfd)
+ call write_integer_fd(pfd,np)
+ call close_file_fd(pfd)
+
+ command_name='cat '//trim(pt_mesh_file2)//' '//trim(pt_mesh_file1)//' '//trim(em_mesh_file)//' > '//trim(mesh_file)
+ print *, ' '
+ print *, 'cat mesh files: '
+ print *, trim(command_name)
+ call system(trim(command_name))
+
+ enddo
+
+ print *, 'Done writing mesh files'
+ print *, ' '
+
+
+end program combine_vol_data
+
+!
+! ------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine reverse_ellipticity(x,y,z,nspl,rspl,espl,espl2)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) :: x,y,z
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+ double precision x1,y1,z1
+
+ double precision ell
+ double precision r,theta,phi,factor
+ double precision cost,p20
+
+ ! gets spherical coordinates
+ x1 = x
+ y1 = y
+ z1 = z
+ call xyz_2_rthetaphi_dble(x1,y1,z1,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
+
+ ! removes ellipticity factor
+ x = x / factor
+ y = y / factor
+ z = z / factor
+
+ end subroutine reverse_ellipticity
+
+!
+! ------------------------------------------------------------------------------------------------
+!
+
+! copy from make_ellipticity.f90 to avoid compiling issues
+
+ 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
+
+!
+! ------------------------------------------------------------------------------------------------
+!
+
+! copy from model_prem.f90 to avoid compiling issues
+
+ 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
+
+ ! compute real physical radius in meters
+ r = x * R_EARTH
+
+ ! calculates density according to radius
+ 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
+
+!
+! ------------------------------------------------------------------------------------------------
+!
+
+! copy from intgrl.f90 to avoid compiling issues
+
+
+ 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
+ double precision, parameter :: third = 1.0d0/3.0d0
+ double precision, parameter :: fifth = 1.0d0/5.0d0
+ double precision, parameter :: sixth = 1.0d0/6.0d0
+
+ double precision rji,yprime(640)
+ double precision s1l,s2l,s3l
+
+ integer i,j,n,kdis(28)
+ integer ndis,nir1
+
+
+
+ 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)
+ s1l = s1(j)
+ s2l = s2(j)
+ s3l = s3(j)
+ sum = sum + r(j)*r(j)*rji*(f(j) &
+ + rji*(0.5d0*s1l + rji*(third*s2l + rji*0.25d0*s3l))) &
+ + 2.0d0*r(j)*rji*rji*(0.5d0*f(j) + rji*(third*s1l + rji*(0.25d0*s2l + rji*fifth*s3l))) &
+ + rji*rji*rji*(third*f(j) + rji*(0.25d0*s1l + rji*(fifth*s2l + rji*sixth*s3l)))
+ 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
+
+!
+! ------------------------------------------------------------------------------------------------
+!
+
+! copy from spline_routines.f90 to avoid compiling issues
+
+! 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
+
+
+!
+! ------------------------------------------------------------------------------------------------
+!
+
+! copy from rthetaphi_xyz.f90 to avoid compiling issues
+
+
+ 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*xmesh + ymesh*ymesh + zmesh*zmesh)
+
+ end subroutine xyz_2_rthetaphi_dble
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/comp_source_spectrum.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/comp_source_spectrum.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/comp_source_spectrum.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/comp_source_spectrum.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ 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/src/comp_source_time_function.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/comp_source_time_function.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/comp_source_time_function.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/comp_source_time_function.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,64 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ 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
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ double precision function comp_source_time_function_rickr(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision t,f0
+
+ ! ricker
+ comp_source_time_function_rickr = (1.d0 - 2.d0*PI*PI*f0*f0*t*t ) &
+ * exp( -PI*PI*f0*f0*t*t )
+
+ !!! another source time function they have called 'ricker' in some old papers,
+ !!! e.g., 'Finite-Frequency Kernels Based on Adjoint Methods' by Liu & Tromp, BSSA (2006)
+ !!! in order to benchmark those simulations, the following formula is needed.
+ ! comp_source_time_function_rickr = -2.d0*PI*PI*f0*f0*f0*t * exp(-PI*PI*f0*f0*t*t)
+
+ end function comp_source_time_function_rickr
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_add_sources.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_add_sources.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_add_sources.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_add_sources.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,433 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_add_sources(myrank,NSOURCES, &
+ accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank,NSOURCES
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ accel_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES) :: sourcearrays
+
+ double precision, dimension(NSOURCES) :: tshift_cmt,hdur_gaussian
+
+ double precision :: DT,t0
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ integer :: it
+
+ ! needed for point force sources
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(NDIM,NDIM,NSOURCES) :: nu_source
+ double precision, dimension(NSOURCES) :: hdur
+
+ ! local parameters
+ double precision :: stf
+ real(kind=CUSTOM_REAL) :: stf_used
+ integer :: isource,i,j,k,iglob,ispec
+ double precision, external :: comp_source_time_function
+ double precision :: f0
+ double precision, external :: comp_source_time_function_rickr
+
+ do isource = 1,NSOURCES
+
+
+ ! add only if this proc carries the source
+ if(myrank == islice_selected_source(isource)) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool_crust_mantle(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec_selected_source(isource))
+
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+
+ !if (it == 1 .and. myrank == 0) then
+ ! write(IMAIN,*) 'using a source of dominant frequency ',f0
+ ! write(IMAIN,*) 'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ ! write(IMAIN,*) 'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ !endif
+
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ stf_used = FACTOR_FORCE_SOURCE * comp_source_time_function_rickr(dble(it-1)*DT-t0-tshift_cmt(isource),f0)
+
+ ! we use a force in a single direction along one of the components:
+ ! x/y/z or E/N/Z-direction would correspond to 1/2/3 = COMPONENT_FORCE_SOURCE
+ ! e.g. nu_source(3,:) here would be a source normal to the surface (z-direction).
+ accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
+ + sngl( nu_source(COMPONENT_FORCE_SOURCE,:,isource) ) * stf_used
+
+ else
+
+ stf = comp_source_time_function(dble(it-1)*DT-t0-tshift_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
+ ispec = ispec_selected_source(isource)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+
+ accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
+ + sourcearrays(:,i,j,k,isource)*stf_used
+
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+
+ endif
+
+ enddo
+
+ end subroutine compute_add_sources
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_add_sources_adjoint(myrank,nrec, &
+ nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
+ accel_crust_mantle,adj_sourcearrays, &
+ nu,xi_receiver,eta_receiver,gamma_receiver, &
+ xigll,yigll,zigll,ibool_crust_mantle, &
+ islice_selected_rec,ispec_selected_rec, &
+ NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
+ it,it_begin,station_name,network_name,DT)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank,nrec,nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ accel_crust_mantle
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ,nadj_rec_local,NTSTEP_BETWEEN_READ_ADJSRC) :: &
+ adj_sourcearrays
+
+ double precision, dimension(NDIM,NDIM,nrec) :: nu
+ double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+ double precision :: DT
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+
+ integer NSTEP_SUB_ADJ
+ integer, dimension(NSTEP_SUB_ADJ) :: iadjsrc_len
+ integer, dimension(NSTEP_SUB_ADJ,2) :: iadjsrc ! to read input in chunks
+ integer, dimension(NSTEP) :: iadj_vec
+
+ integer :: it,it_begin,itime
+
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ ! local parameters
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearray
+ integer :: irec,irec_local,i,j,k,iglob,it_sub_adj
+ character(len=150) :: adj_source_file
+ logical :: ibool_read_adj_arrays
+
+ ! figure out if we need to read in a chunk of the adjoint source at this timestep
+ it_sub_adj = ceiling( dble(it)/dble(NTSTEP_BETWEEN_READ_ADJSRC) ) !chunk_number
+ ibool_read_adj_arrays = (((it == it_begin) .or. (mod(it-1,NTSTEP_BETWEEN_READ_ADJSRC) == 0)) &
+ .and. (nadj_rec_local > 0))
+
+ ! needs to read in a new chunk/block of the adjoint source
+ if(ibool_read_adj_arrays) then
+
+ ! temporary source array
+ allocate(adj_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NTSTEP_BETWEEN_READ_ADJSRC))
+ adj_sourcearray = 0._CUSTOM_REAL
+
+ irec_local = 0
+ do irec = 1, nrec
+ ! check that the source slice number is okay
+ if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROCTOT_VAL-1) then
+ if(islice_selected_rec(irec) < 0) call exit_MPI(myrank,'islice < 0')
+ if(islice_selected_rec(irec) > NPROCTOT_VAL-1) call exit_MPI(myrank,'islice > NPROCTOT_VAL-1')
+ call exit_MPI(myrank,'now: something is wrong with the source slice number in adjoint simulation')
+ endif
+ ! compute source arrays
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+
+ ! reads in **sta**.**net**.**LH**.adj files
+ adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+ call compute_arrays_source_adjoint(myrank,adj_source_file, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ nu(:,:,irec),adj_sourcearray, xigll,yigll,zigll,iadjsrc_len(it_sub_adj), &
+ iadjsrc,it_sub_adj,NSTEP_SUB_ADJ,NTSTEP_BETWEEN_READ_ADJSRC,DT)
+
+ ! stores source array
+ ! note: the adj_sourcearrays has a time stepping from 1 to NTSTEP_BETWEEN_READ_ADJSRC
+ ! this gets overwritten every time a new block/chunk is read in
+ do itime = 1,NTSTEP_BETWEEN_READ_ADJSRC
+ adj_sourcearrays(:,:,:,:,irec_local,itime) = adj_sourcearray(:,:,:,:,itime)
+ enddo
+
+ endif
+ enddo
+ if(irec_local /= nadj_rec_local) &
+ call exit_MPI(myrank,'irec_local /= nadj_rec_local in adjoint simulation')
+
+ deallocate(adj_sourcearray)
+
+ endif
+
+ irec_local = 0
+ do irec = 1,nrec
+
+ ! adds source (only if this proc carries the source)
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+
+ ! adds source contributions
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec))
+
+
+ ! adds adjoint source acting at this time step (it):
+ !
+ ! note: we use index iadj_vec(it) which is the corresponding time step
+ ! for the adjoint source acting at this time step (it)
+ !
+ ! see routine: setup_sources_receivers_adjindx() how this adjoint index array is set up
+ !
+ ! e.g. total length NSTEP = 3000, chunk length NTSTEP_BETWEEN_READ_ADJSRC= 1000
+ ! then for it=1,..1000, first block has iadjsrc(1,1) with start = 2001 and end = 3000;
+ ! corresponding iadj_vec(it) goes from
+ ! iadj_vec(1) = 1000, iadj_vec(2) = 999 to iadj_vec(1000) = 1,
+ ! that is, originally the idea was
+ ! adj_sourcearrays(.. iadj_vec(1) ) corresponds to adjoint source trace at time index 3000
+ ! adj_sourcearrays(.. iadj_vec(2) ) corresponds to adjoint source trace at time index 2999
+ ! ..
+ ! adj_sourcearrays(.. iadj_vec(1000) ) corresponds to adjoint source trace at time index 2001
+ ! then a new block will be read, etc, and it is going down till to adjoint source trace at time index 1
+ !
+ ! now comes the tricky part:
+ ! adjoint source traces are based on the seismograms from the forward run;
+ ! such seismograms have a time step index 1 which corresponds to time -t0
+ ! then time step index 2 which corresponds to -t0 + DT, and
+ ! the last time step in the file at time step NSTEP corresponds to time -t0 + (NSTEP-1)*DT
+ ! (see how we add the sources to the simulation in compute_add_sources() and
+ ! how we write/save the seismograms and wavefields at the end of the time loop).
+ !
+ ! then you use that seismogram and take e.g. the velocity of it for a travetime adjoint source
+ !
+ ! now we read it in again, and remember the last time step in
+ ! the file at NSTEP corresponds to -t0 + (NSTEP-1)*DT
+ !
+ ! the same time step is saved for the forward wavefields to reconstruct them;
+ ! however, the Newark time scheme acts at the very beginning of this time loop
+ ! such that we have the backward/reconstructed wavefield updated by
+ ! a single time step into the direction -DT and b_displ(it=1) would corresponds to -t0 + (NSTEP-1)*DT - DT
+ ! after the Newark (predictor) time step update.
+ ! however, we will read the backward/reconstructed wavefield at the end of the first time loop,
+ ! such that b_displ(it=1) corresponds to -t0 + (NSTEP-1)*DT (which is the one saved in the files).
+ !
+ ! for the kernel calculations, we want:
+ ! adjoint wavefield at time t, starting from 0 to T
+ ! and forward wavefield at time T-t, starting from T down to 0
+ ! let's say time 0 corresponds to -t0 = -t0 + (it - 1)*DT at it=1
+ ! and time T corresponds to -t0 + (NSTEP-1)*DT at it = NSTEP
+ !
+ ! as seen before, the time for the forward wavefield b_displ(it=1) would then
+ ! correspond to time -t0 + (NSTEP-1)*DT - DT, which is T - DT.
+ ! the corresponding time for the adjoint wavefield thus would be 0 + DT
+ ! and the adjoint source index would be iadj_vec(it+1)
+ ! however, iadj_vec(it+1) which would go from 999 down to 0. 0 is out of bounds.
+ ! we thus would have to read in the adjoint source trace beginning from 2999 down to 0.
+ ! index 0 is not defined in the adjoint source trace, and would be set to zero.
+ !
+ ! however, since this complicates things, we read the backward/reconstructed
+ ! wavefield at the end of the first time loop, such that b_displ(it=1) corresponds to -t0 + (NSTEP-1)*DT.
+ ! assuming that until that end the backward/reconstructed wavefield and adjoint fields
+ ! have a zero contribution to adjoint kernels.
+ accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
+ + adj_sourcearrays(:,i,j,k,irec_local,iadj_vec(it))
+
+ enddo
+ enddo
+ enddo
+ endif
+
+ enddo
+
+
+ end subroutine compute_add_sources_adjoint
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+ b_accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank,NSOURCES,NSTEP
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_accel_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES) :: sourcearrays
+
+ double precision, dimension(NSOURCES) :: tshift_cmt,hdur_gaussian
+
+ double precision :: DT,t0
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ integer :: it
+ ! needed for point force sources
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(NDIM,NDIM,NSOURCES) :: nu_source
+ double precision, dimension(NSOURCES) :: hdur
+
+ ! local parameters
+ double precision :: stf
+ real(kind=CUSTOM_REAL) :: stf_used
+ integer :: isource,i,j,k,iglob,ispec
+ double precision, external :: comp_source_time_function
+ double precision :: f0
+ double precision, external :: comp_source_time_function_rickr
+
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+! note on backward/reconstructed wavefields:
+! time for b_displ( it ) corresponds to (NSTEP - (it-1) - 1 )*DT - t0 ...
+! as we start with saved wavefields b_displ( 1 ) = displ( NSTEP ) which correspond
+! to a time (NSTEP - 1)*DT - t0
+! (see sources for simulation_type 1 and seismograms)
+!
+! now, at the beginning of the time loop, the numerical Newmark time scheme updates
+! the wavefields, that is b_displ( it=1) would correspond to time (NSTEP -1 - 1)*DT - t0.
+! however, we read in the backward/reconstructed wavefields at the end of the Newmark time scheme
+! in the first (it=1) time loop.
+! this leads to the timing (NSTEP-(it-1)-1)*DT-t0-tshift_cmt for the source time function here
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool_crust_mantle(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec_selected_source(isource))
+
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+
+ !if (it == 1 .and. myrank == 0) then
+ ! write(IMAIN,*) 'using a source of dominant frequency ',f0
+ ! write(IMAIN,*) 'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ ! write(IMAIN,*) 'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ !endif
+
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ stf_used = FACTOR_FORCE_SOURCE * comp_source_time_function_rickr(dble(NSTEP-it)*DT-t0-tshift_cmt(isource),f0)
+
+ ! e.g. we use nu_source(3,:) here if we want a source normal to the surface.
+ ! note: time step is now at NSTEP-it
+ b_accel_crust_mantle(:,iglob) = b_accel_crust_mantle(:,iglob) &
+ + sngl( nu_source(COMPONENT_FORCE_SOURCE,:,isource) ) * stf_used
+
+ else
+
+ ! see note above: time step corresponds now to NSTEP-it
+ stf = comp_source_time_function(dble(NSTEP-it)*DT-t0-tshift_cmt(isource),hdur_gaussian(isource))
+
+ ! 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
+ ispec = ispec_selected_source(isource)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+
+ b_accel_crust_mantle(:,iglob) = b_accel_crust_mantle(:,iglob) &
+ + sourcearrays(:,i,j,k,isource)*stf_used
+
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+
+ endif
+
+ enddo
+
+ end subroutine compute_add_sources_backward
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_arrays_source.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_arrays_source.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_arrays_source.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_arrays_source.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,587 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_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_source_adjoint(myrank, adj_source_file, &
+ xi_receiver,eta_receiver,gamma_receiver, nu,adj_sourcearray, &
+ xigll,yigll,zigll,NSTEP_BLOCK,iadjsrc,it_sub_adj,NSTEP_SUB_ADJ, &
+ NTSTEP_BETWEEN_READ_ADJSRC,DT)
+
+ implicit none
+
+ include 'constants.h'
+
+! input -- notice here NSTEP_BLOCK is different from the NSTEP in the main program
+! instead NSTEP_BLOCK = iadjsrc_len(it_sub_adj), the length of this specific block
+
+ integer myrank, NSTEP_BLOCK
+
+ double precision xi_receiver, eta_receiver, gamma_receiver
+ double precision DT
+
+ 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(NDIM,NGLLX,NGLLY,NGLLZ,NTSTEP_BETWEEN_READ_ADJSRC)
+
+ ! 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,parameter :: scale_displ_inv = 1.d0/R_EARTH
+
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
+ hgammar(NGLLZ), hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL) :: adj_src(NDIM,NSTEP_BLOCK),adj_src_u(NDIM,NSTEP_BLOCK)
+
+ integer icomp, itime, i, j, k, ios
+ integer it_start,it_end,index_i
+ real(kind=CUSTOM_REAL) :: junk
+ !character(len=3),dimension(NDIM) :: comp = (/ "LHN", "LHE", "LHZ" /)
+ character(len=3),dimension(NDIM) :: comp
+ character(len=150) :: filename
+ character(len=2) :: bic
+
+! by Ebru
+ call band_instrument_code(DT,bic)
+ comp(1) = bic(1:2)//'N'
+ comp(2) = bic(1:2)//'E'
+ comp(3) = bic(1:2)//'Z'
+!
+
+ ! (sub)trace start and end
+ ! reading starts in chunks of NSTEP_BLOCK from the end of the trace,
+ ! i.e. as an example: total length NSTEP = 3000, chunk length NSTEP_BLOCK= 1000
+ ! then it will read in first it_start=2001 to it_end=3000,
+ ! second time, it will be it_start=1001 to it_end=2000 and so on...
+ it_start = iadjsrc(it_sub_adj,1)
+ it_end = iadjsrc(it_sub_adj,1)+NSTEP_BLOCK-1
+
+
+ ! unfortunately, things become more tricky because of the Newark time scheme at
+ ! the very beginning of the time loop. however, when we read in the backward/reconstructed
+ ! wavefields at the end of the first time loop, we can use the adjoint source index from 3000 down to 1.
+ !
+ ! see the comment on where we add the adjoint source (compute_add_sources_adjoint()).
+ !
+ ! otherwise,
+ ! we would have to shift this indices by minus 1, to read in the adjoint source trace between 0 to 2999.
+ ! since 0 index is out of bounds, we would have to put that adjoint source displacement artifically to zero
+ !
+ ! here now, it_start is now 2001 and it_end = 3000, then 1001 to 2000, then 1 to 1000.
+ it_start = it_start
+ it_end = it_end
+
+ adj_src = 0._CUSTOM_REAL
+ do icomp = 1, NDIM
+
+ ! opens adjoint component file
+ filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit=IIN,file=trim(filename),status='old',action='read',iostat=ios)
+
+ ! note: adjoint source files must be available for all three components E/N/Z, even
+ ! if a component is just zeroed out
+ if (ios /= 0) then
+ ! adjoint source file not found
+ ! stops simulation
+ call exit_MPI(myrank,&
+ 'file '//trim(filename)//' not found, please check with your STATIONS_ADJOINT file')
+ endif
+ !if (ios /= 0) cycle ! cycles to next file
+
+ ! jumps over unused trace length
+ do itime =1,it_start-1
+ read(IIN,*,iostat=ios) junk,junk
+ if( ios /= 0) &
+ call exit_MPI(myrank,&
+ 'file '//trim(filename)//' has wrong length, please check with your simulation duration')
+ enddo
+
+ ! reads in (sub)trace
+ do itime = it_start,it_end
+
+ ! index will run from 1 to NSTEP_BLOCK
+ index_i = itime - it_start + 1
+
+ ! would skip read and set source artifically to zero if out of bounds, see comments above
+ if( it_start == 0 .and. itime == 0 ) then
+ adj_src(icomp,1) = 0._CUSTOM_REAL
+ cycle
+ endif
+
+ ! reads in adjoint source trace
+ !read(IIN,*,iostat=ios) junk, adj_src(icomp,itime-it_start+1)
+ read(IIN,*,iostat=ios) junk, adj_src(icomp,index_i)
+
+ if( ios /= 0) &
+ call exit_MPI(myrank, &
+ 'file '//trim(filename)//' has wrong length, please check with your simulation duration')
+ enddo
+
+ close(IIN)
+
+ enddo
+
+ ! non-dimensionalize
+ adj_src = adj_src*scale_displ_inv
+
+ ! rotates to cartesian
+ do itime = 1, NSTEP_BLOCK
+ adj_src_u(:,itime) = nu(1,:) * adj_src(1,itime) &
+ + nu(2,:) * adj_src(2,itime) &
+ + nu(3,:) * adj_src(3,itime)
+ enddo
+
+ ! receiver interpolators
+ 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)
+
+ ! adds interpolated source contribution to all GLL points within this element
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ do itime = 1, NSTEP_BLOCK
+ adj_sourcearray(:,i,j,k,itime) = hxir(i) * hetar(j) * hgammar(k) * adj_src_u(:,itime)
+ enddo
+ enddo
+ enddo
+ enddo
+
+
+end subroutine compute_arrays_source_adjoint
+
+! =======================================================================
+
+! compute the integrated derivatives of source parameters (M_jk and X_s)
+
+subroutine compute_adj_source_frechet(displ_s,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ eps_s,eps_m_s,eps_m_l_s, &
+ hxir,hetar,hgammar,hpxir,hpetar,hpgammar, hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+ implicit none
+
+ include 'constants.h'
+
+ ! input
+ real(kind=CUSTOM_REAL) :: displ_s(NDIM,NGLLX,NGLLY,NGLLZ)
+ double precision :: Mxx, Myy, Mzz, Mxy, Mxz, Myz
+ ! output
+ real(kind=CUSTOM_REAL) :: eps_s(NDIM,NDIM), eps_m_s, eps_m_l_s(NDIM)
+
+ ! auxilliary
+ double precision :: hxir(NGLLX), hetar(NGLLY), hgammar(NGLLZ), &
+ hpxir(NGLLX),hpetar(NGLLY),hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+! local variables
+ real(kind=CUSTOM_REAL) :: tempx1l,tempx2l,tempx3l, tempy1l,tempy2l,tempy3l, &
+ tempz1l,tempz2l,tempz3l, hp1, hp2, hp3, &
+ xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl, &
+ duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl, &
+ xix_s,xiy_s,xiz_s,etax_s,etay_s,etaz_s,gammax_s,gammay_s,gammaz_s, &
+ hlagrange_xi, hlagrange_eta, hlagrange_gamma, hlagrange
+
+ real(kind=CUSTOM_REAL) :: eps(NDIM,NDIM), eps_array(NDIM,NDIM,NGLLX,NGLLY,NGLLZ), &
+ eps_m_array(NGLLX,NGLLY,NGLLZ)
+
+ integer i,j,k,l
+
+
+! first compute the strain at all the GLL points of the source element
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ tempx1l = tempx1l + displ_s(1,l,j,k)*hp1
+ tempy1l = tempy1l + displ_s(2,l,j,k)*hp1
+ tempz1l = tempz1l + displ_s(3,l,j,k)*hp1
+
+ hp2 = hprime_yy(j,l)
+ tempx2l = tempx2l + displ_s(1,i,l,k)*hp2
+ tempy2l = tempy2l + displ_s(2,i,l,k)*hp2
+ tempz2l = tempz2l + displ_s(3,i,l,k)*hp2
+
+ hp3 = hprime_zz(k,l)
+ tempx3l = tempx3l + displ_s(1,i,j,l)*hp3
+ tempy3l = tempy3l + displ_s(2,i,j,l)*hp3
+ tempz3l = tempz3l + displ_s(3,i,j,l)*hp3
+ enddo
+
+! dudx
+ xixl = xix(i,j,k)
+ xiyl = xiy(i,j,k)
+ xizl = xiz(i,j,k)
+ etaxl = etax(i,j,k)
+ etayl = etay(i,j,k)
+ etazl = etaz(i,j,k)
+ gammaxl = gammax(i,j,k)
+ gammayl = gammay(i,j,k)
+ gammazl = gammaz(i,j,k)
+
+ 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
+
+! strain eps_jk
+ eps(1,1) = duxdxl
+ eps(1,2) = (duxdyl + duydxl) / 2
+ eps(1,3) = (duxdzl + duzdxl) / 2
+ eps(2,2) = duydyl
+ eps(2,3) = (duydzl + duzdyl) / 2
+ eps(3,3) = duzdzl
+ eps(2,1) = eps(1,2)
+ eps(3,1) = eps(1,3)
+ eps(3,2) = eps(2,3)
+
+ eps_array(:,:,i,j,k) = eps(:,:)
+
+! Mjk eps_jk
+ eps_m_array(i,j,k) = Mxx * eps(1,1) + Myy * eps(2,2) + Mzz * eps(3,3) + &
+ 2 * (Mxy * eps(1,2) + Mxz * eps(1,3) + Myz * eps(2,3))
+
+ enddo
+ enddo
+ enddo
+
+ ! interpolate the strain eps_s(:,:) from eps_array(:,:,i,j,k)
+ eps_s = 0.; eps_m_s=0.;
+ xix_s = 0.; xiy_s = 0.; xiz_s = 0.
+ etax_s = 0.; etay_s = 0.; etaz_s = 0.
+ gammax_s = 0.; gammay_s = 0.; gammaz_s = 0.
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ hlagrange = hxir(i)*hetar(j)*hgammar(k)
+
+ eps_s(1,1) = eps_s(1,1) + eps_array(1,1,i,j,k)*hlagrange
+ eps_s(1,2) = eps_s(1,2) + eps_array(1,2,i,j,k)*hlagrange
+ eps_s(1,3) = eps_s(1,3) + eps_array(1,3,i,j,k)*hlagrange
+ eps_s(2,2) = eps_s(2,2) + eps_array(2,2,i,j,k)*hlagrange
+ eps_s(2,3) = eps_s(2,3) + eps_array(2,3,i,j,k)*hlagrange
+ eps_s(3,3) = eps_s(3,3) + eps_array(3,3,i,j,k)*hlagrange
+
+ xix_s = xix_s + xix(i,j,k)*hlagrange
+ xiy_s = xiy_s + xiy(i,j,k)*hlagrange
+ xiz_s = xiz_s + xiz(i,j,k)*hlagrange
+ etax_s = etax_s + etax(i,j,k)*hlagrange
+ etay_s = etay_s + etay(i,j,k)*hlagrange
+ etaz_s = etaz_s + etaz(i,j,k)*hlagrange
+ gammax_s = gammax_s + gammax(i,j,k)*hlagrange
+ gammay_s = gammay_s + gammay(i,j,k)*hlagrange
+ gammaz_s = gammaz_s + gammaz(i,j,k)*hlagrange
+
+ eps_m_s = eps_m_s + eps_m_array(i,j,k)*hlagrange
+ enddo
+ enddo
+ enddo
+
+! for completion purpose, not used in specfem3D.f90
+ eps_s(2,1) = eps_s(1,2)
+ eps_s(3,1) = eps_s(1,3)
+ eps_s(3,2) = eps_s(2,3)
+
+! compute the gradient of M_jk * eps_jk, and then interpolate it
+
+ eps_m_l_s = 0.
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ hlagrange_xi = hpxir(i)*hetar(j)*hgammar(k)
+ hlagrange_eta = hxir(i)*hpetar(j)*hgammar(k)
+ hlagrange_gamma = hxir(i)*hetar(j)*hpgammar(k)
+
+ eps_m_l_s(1) = eps_m_l_s(1) + eps_m_array(i,j,k) * (hlagrange_xi * xix_s &
+ + hlagrange_eta * etax_s + hlagrange_gamma * gammax_s)
+ eps_m_l_s(2) = eps_m_l_s(2) + eps_m_array(i,j,k) * (hlagrange_xi * xiy_s &
+ + hlagrange_eta * etay_s + hlagrange_gamma * gammay_s)
+ eps_m_l_s(3) = eps_m_l_s(3) + eps_m_array(i,j,k) * (hlagrange_xi * xiz_s &
+ + hlagrange_eta * etaz_s + hlagrange_gamma * gammaz_s)
+
+ enddo
+ enddo
+ enddo
+
+end subroutine compute_adj_source_frechet
+
+!================================================================
+!
+! deprecated...
+!
+!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
+!
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_boundary_kernel.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_boundary_kernel.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_boundary_kernel.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_boundary_kernel.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine compute_boundary_kernel(displ,accel,b_displ,nspec,iregion_code, &
+ ystore,zstore,ibool,idoubling, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ rhostore,kappavstore,muvstore,kappahstore,muhstore,eta_anisostore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ k_disc,ibelm_disc,normal_disc,b_kl,fluid_solid_boundary,NSPEC2D_DISC)
+
+ implicit none
+
+ include 'constants.h'
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,*) :: displ,accel,b_displ
+ integer nspec, iregion_code
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer, dimension(*) :: idoubling
+ real(kind=CUSTOM_REAL), dimension(*) :: ystore,zstore
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: rhostore, kappavstore,muvstore
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: kappahstore,muhstore,eta_anisostore
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, c34store,c35store,c36store, &
+ c44store,c45store,c46store,c55store,c56store,c66store
+
+ integer NSPEC2D_DISC, k_disc
+ integer :: ibelm_disc(NSPEC2D_DISC)
+ real(kind=CUSTOM_REAL) :: normal_disc(NDIM,NGLLX,NGLLY,NSPEC2D_DISC)
+ real(kind=CUSTOM_REAL) :: b_kl(NGLLX,NGLLY,NSPEC2D_DISC)
+ logical :: fluid_solid_boundary
+
+! --- local variables ---
+ integer ispec2D,i,j,k,iglob,ispec
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: displl, accell, b_displl, Kdvect
+ real(kind=CUSTOM_REAL), dimension(NDIM) :: normal, temp1, temp2, temp3
+ real(kind=CUSTOM_REAL) :: xixl, xiyl, xizl, etaxl, etayl, etazl, gammaxl, gammayl, gammazl
+ real(kind=CUSTOM_REAL), dimension(NDIM,NDIM,NGLLX,NGLLY,NGLLZ) :: dsdx, sigma, b_dsdx, b_sigma
+ real(kind=CUSTOM_REAL) :: b_kl_2(NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL) :: dKdx(NDIM,NDIM)
+
+ ! ------
+
+ ! initialization
+ b_kl = 0.
+
+ do ispec2D = 1, NSPEC2D_DISC
+
+ ! assign local matrices
+ ispec = ibelm_disc(ispec2D)
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ displl(:,i,j,k) = displ(:,iglob)
+ accell(:,i,j,k) = accel(:,iglob)
+ b_displl(:,i,j,k) = b_displ(:,iglob)
+ enddo
+ enddo
+ enddo
+
+ ! strain and stress
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ normal(:) = normal_disc(:,i,j,ispec2D)
+ 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)
+
+ ! ----- adjoint strain ------
+ temp1(:) = matmul(displl(:,:,j,k), hprime_xx(i,:))
+ temp2(:) = matmul(displl(:,i,:,k), hprime_yy(j,:))
+ temp3(:) = matmul(displl(:,i,j,:), hprime_zz(k,:))
+
+ dsdx(1,1,i,j,k) = xixl*temp1(1) + etaxl*temp2(1) + gammaxl*temp3(1)
+ dsdx(1,2,i,j,k) = xiyl*temp1(1) + etayl*temp2(1) + gammayl*temp3(1)
+ dsdx(1,3,i,j,k) = xizl*temp1(1) + etazl*temp2(1) + gammazl*temp3(1)
+
+ dsdx(2,1,i,j,k) = xixl*temp1(2) + etaxl*temp2(2) + gammaxl*temp3(2)
+ dsdx(2,2,i,j,k) = xiyl*temp1(2) + etayl*temp2(2) + gammayl*temp3(2)
+ dsdx(2,3,i,j,k) = xizl*temp1(2) + etazl*temp2(2) + gammazl*temp3(2)
+
+ dsdx(3,1,i,j,k) = xixl*temp1(3) + etaxl*temp2(3) + gammaxl*temp3(3)
+ dsdx(3,2,i,j,k) = xiyl*temp1(3) + etayl*temp2(3) + gammayl*temp3(3)
+ dsdx(3,3,i,j,k) = xizl*temp1(3) + etazl*temp2(3) + gammazl*temp3(3)
+
+ ! ------ adjoint stress -------
+ call compute_stress_from_strain(dsdx(:,:,i,j,k),sigma(:,:,i,j,k),i,j,k,ispec,iregion_code, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ ystore,zstore,ibool,idoubling)
+
+ ! ----- forward strain -------
+ temp1(:) = matmul(b_displl(:,:,j,k), hprime_xx(i,:))
+ temp2(:) = matmul(b_displl(:,i,:,k), hprime_yy(j,:))
+ temp3(:) = matmul(b_displl(:,i,j,:), hprime_zz(k,:))
+
+ b_dsdx(1,1,i,j,k) = xixl*temp1(1) + etaxl*temp2(1) + gammaxl*temp3(1)
+ b_dsdx(1,2,i,j,k) = xiyl*temp1(1) + etayl*temp2(1) + gammayl*temp3(1)
+ b_dsdx(1,3,i,j,k) = xizl*temp1(1) + etazl*temp2(1) + gammazl*temp3(1)
+
+ b_dsdx(2,1,i,j,k) = xixl*temp1(2) + etaxl*temp2(2) + gammaxl*temp3(2)
+ b_dsdx(2,2,i,j,k) = xiyl*temp1(2) + etayl*temp2(2) + gammayl*temp3(2)
+ b_dsdx(2,3,i,j,k) = xizl*temp1(2) + etazl*temp2(2) + gammazl*temp3(2)
+
+ b_dsdx(3,1,i,j,k) = xixl*temp1(3) + etaxl*temp2(3) + gammaxl*temp3(3)
+ b_dsdx(3,2,i,j,k) = xiyl*temp1(3) + etayl*temp2(3) + gammayl*temp3(3)
+ b_dsdx(3,3,i,j,k) = xizl*temp1(3) + etazl*temp2(3) + gammazl*temp3(3)
+
+ ! ----- forward stress ---------
+ call compute_stress_from_strain(b_dsdx(:,:,i,j,k),b_sigma(:,:,i,j,k),i,j,k,ispec,iregion_code, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ ystore,zstore,ibool,idoubling)
+
+ ! ---- precompute K_d for F-S boundaries ----
+ if (fluid_solid_boundary) then
+ Kdvect(:,i,j,k) = dot_product( normal(:), matmul(sigma(:,:,i,j,k),normal(:)) ) * b_displl(:,i,j,k) &
+ + dot_product( normal(:), matmul(b_sigma(:,:,i,j,k),normal(:)) ) * displl(:,i,j,k)
+ ! important: take only the surface part of the Kdvect
+ Kdvect(:,i,j,k) = Kdvect(:,i,j,k) - normal(:) * dot_product(Kdvect(:,i,j,k),normal(:))
+ endif
+
+
+ ! ----- kernel contributions from all boundaries (S-S and F-S)-----
+ if (k == k_disc) then
+ b_kl(i,j,ispec2D) = rhostore(i,j,k,ispec) * dot_product(b_displl(:,i,j,k),accell(:,i,j,k)) &
+ + dot_product(b_dsdx(1,:,i,j,k),sigma(1,:,i,j,k)) &
+ + dot_product(b_dsdx(2,:,i,j,k),sigma(2,:,i,j,k)) &
+ + dot_product(b_dsdx(3,:,i,j,k),sigma(3,:,i,j,k)) &
+ - dot_product( matmul(b_dsdx(:,:,i,j,k), normal(:)), matmul(sigma(:,:,i,j,k),normal(:)) ) &
+ - dot_product( matmul(dsdx(:,:,i,j,k), normal(:)), matmul(b_sigma(:,:,i,j,k),normal(:)) )
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ! ---- compute surface gradient of K_h for the surface element ----
+ if (fluid_solid_boundary) then
+
+ k = k_disc
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ normal(:) = normal_disc(:,i,j,ispec2D)
+
+ 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)
+
+ ! ----- gradient of vector boundary kernel K_h------
+ temp1(:) = matmul(Kdvect(:,:,j,k), hprime_xx(i,:))
+ temp2(:) = matmul(Kdvect(:,i,:,k), hprime_yy(j,:))
+ temp3(:) = matmul(Kdvect(:,i,j,:), hprime_zz(k,:))
+
+ dKdx(1,1) = xixl*temp1(1) + etaxl*temp2(1) + gammaxl*temp3(1)
+ dKdx(1,2) = xiyl*temp1(1) + etayl*temp2(1) + gammayl*temp3(1)
+ dKdx(1,3) = xizl*temp1(1) + etazl*temp2(1) + gammazl*temp3(1)
+
+ dKdx(2,1) = xixl*temp1(2) + etaxl*temp2(2) + gammaxl*temp3(2)
+ dKdx(2,2) = xiyl*temp1(2) + etayl*temp2(2) + gammayl*temp3(2)
+ dKdx(2,3) = xizl*temp1(2) + etazl*temp2(2) + gammazl*temp3(2)
+
+ dKdx(3,1) = xixl*temp1(3) + etaxl*temp2(3) + gammaxl*temp3(3)
+ dKdx(3,2) = xiyl*temp1(3) + etayl*temp2(3) + gammayl*temp3(3)
+ dKdx(3,3) = xizl*temp1(3) + etazl*temp2(3) + gammazl*temp3(3)
+
+ ! ----- extra boundary kernel contribution for F-S ------
+ b_kl_2(i,j) = dKdx(1,1) + dKdx(2,2) + dKdx(3,3) + &
+ dot_product( normal(:),matmul(dKdx(:,:),normal(:)) )
+ enddo
+ enddo
+
+ b_kl(:,:,ispec2D) = b_kl(:,:,ispec2D) - b_kl_2(:,:)
+ endif
+
+ enddo
+
+ end subroutine compute_boundary_kernel
+
+
+! ==========================================================================================
+
+
+subroutine compute_stress_from_strain(dsdx,sigma,i,j,k,ispec,iregion_code, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ ystore,zstore,ibool,idoubling)
+
+
+ implicit none
+
+ include 'constants.h'
+ include 'OUTPUT_FILES/values_from_mesher.h'
+
+ real(kind=CUSTOM_REAL) :: dsdx(NDIM,NDIM), sigma(NDIM,NDIM)
+ integer i, j, k, ispec, iregion_code
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: kappavstore,muvstore, &
+ kappahstore,muhstore,eta_anisostore
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,*) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store
+ real(kind=CUSTOM_REAL), dimension(*) :: ystore,zstore
+ integer, dimension(NGLLX,NGLLY,NGLLZ,*) :: ibool
+ integer, dimension(*) :: idoubling
+
+! --- local variables ---
+ 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) :: duxdxl,duydyl,duzdzl,duxdxl_plus_duydyl_plus_duzdzl
+ 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) kappal,mul,kappavl,kappahl,muvl,muhl,lambdal,lambdalplus2mul
+ 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
+
+ integer :: iglob
+
+
+ ! --- precompute sum ---
+
+ duxdxl_plus_duydyl = dsdx(1,1) + dsdx(2,2)
+ duxdxl_plus_duzdzl = dsdx(1,1) + dsdx(3,3)
+ duydyl_plus_duzdzl = dsdx(2,2) + dsdx(3,3)
+ duxdyl_plus_duydxl = dsdx(1,2) + dsdx(2,1)
+ duzdxl_plus_duxdzl = dsdx(3,1) + dsdx(1,3)
+ duzdyl_plus_duydzl = dsdx(3,2) + dsdx(2,3)
+ duxdxl = dsdx(1,1)
+ duydyl = dsdx(2,2)
+ duzdzl = dsdx(3,3)
+
+ ! ----------------- mantle-----------------------
+
+ if (iregion_code == IREGION_CRUST_MANTLE) then
+
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+
+ c11 = c11store(i,j,k,ispec)
+ c12 = c12store(i,j,k,ispec)
+ c13 = c13store(i,j,k,ispec)
+ c14 = c14store(i,j,k,ispec)
+ c15 = c15store(i,j,k,ispec)
+ c16 = c16store(i,j,k,ispec)
+ c22 = c22store(i,j,k,ispec)
+ c23 = c23store(i,j,k,ispec)
+ c24 = c24store(i,j,k,ispec)
+ c25 = c25store(i,j,k,ispec)
+ c26 = c26store(i,j,k,ispec)
+ c33 = c33store(i,j,k,ispec)
+ c34 = c34store(i,j,k,ispec)
+ c35 = c35store(i,j,k,ispec)
+ c36 = c36store(i,j,k,ispec)
+ c44 = c44store(i,j,k,ispec)
+ c45 = c45store(i,j,k,ispec)
+ c46 = c46store(i,j,k,ispec)
+ c55 = c55store(i,j,k,ispec)
+ c56 = c56store(i,j,k,ispec)
+ c66 = c66store(i,j,k,ispec)
+
+ sigma(1,1) = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
+ c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
+
+ sigma(2,2) = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
+ c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
+
+ sigma(3,3) = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
+ c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
+
+ sigma(1,2) = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
+ c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
+
+ sigma(1,3) = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
+ c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
+
+ sigma(2,3) = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
+ c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
+
+ else if(.not. (TRANSVERSE_ISOTROPY_VAL .and. (idoubling(ispec) == IFLAG_80_MOHO .or. idoubling(ispec) == IFLAG_220_80))) then
+
+ kappal = kappavstore(i,j,k,ispec)
+ mul = muvstore(i,j,k,ispec)
+
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
+
+ sigma(1,1) = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma(2,2) = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma(3,3) = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+
+ sigma(1,2) = mul*duxdyl_plus_duydxl
+ sigma(1,3) = mul*duzdxl_plus_duxdzl
+ sigma(2,3) = mul*duzdyl_plus_duydzl
+
+ else
+
+ kappavl = kappavstore(i,j,k,ispec)
+ muvl = muvstore(i,j,k,ispec)
+
+ kappahl = kappahstore(i,j,k,ispec)
+ muhl = muhstore(i,j,k,ispec)
+
+ 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(1,1) = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
+ c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
+
+ sigma(2,2) = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
+ c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
+
+ sigma(3,3) = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
+ c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
+
+ sigma(1,2) = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
+ c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
+
+ sigma(1,3) = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
+ c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
+
+ sigma(2,3) = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
+ c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
+
+ endif ! end of test whether isotropic or anisotropic element for the mantle
+
+! ------------------- outer core --------------------------
+
+ else if (iregion_code == IREGION_OUTER_CORE) then
+
+ kappal = kappavstore(i,j,k,ispec)
+ duxdxl_plus_duydyl_plus_duzdzl = duxdxl+duydyl_plus_duzdzl
+
+ sigma(1,1) = kappal * duxdxl_plus_duydyl_plus_duzdzl
+ sigma(2,2) = sigma(1,1)
+ sigma(3,3) = sigma(1,1)
+
+ sigma(1,2) = 0
+ sigma(1,3) = 0
+ sigma(2,3) = 0
+
+! ------------------ inner core -------------------------
+
+ else if (iregion_code == IREGION_INNER_CORE) then
+
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+
+! elastic tensor for hexagonal symmetry in reduced notation:
+!
+! c11 c12 c13 0 0 0
+! c12 c11 c13 0 0 0
+! c13 c13 c33 0 0 0
+! 0 0 0 c44 0 0
+! 0 0 0 0 c44 0
+! 0 0 0 0 0 (c11-c12)/2
+!
+! in terms of the A, C, L, N and F of Love (1927):
+!
+! c11 = A
+! c12 = A-2N
+! c13 = F
+! c33 = C
+! c44 = L
+! notice this is already in global coordinates
+
+ c11 = c11store(i,j,k,ispec)
+ c12 = c12store(i,j,k,ispec)
+ c13 = c13store(i,j,k,ispec)
+ c33 = c33store(i,j,k,ispec)
+ c44 = c44store(i,j,k,ispec)
+
+ sigma(1,1) = c11*duxdxl + c12*duydyl + c13*duzdzl
+ sigma(2,2) = c12*duxdxl + c11*duydyl + c13*duzdzl
+ sigma(3,3) = c13*duxdxl + c13*duydyl + c33*duzdzl
+ sigma(1,2) = 0.5*(c11-c12)*duxdyl_plus_duydxl
+ sigma(1,3) = c44*duzdxl_plus_duxdzl
+ sigma(2,3) = c44*duzdyl_plus_duydzl
+ else
+
+! inner core with no anisotropy, use kappav and muv for instance
+! layer with no anisotropy, use kappav and muv for instance
+ kappal = kappavstore(i,j,k,ispec)
+ mul = muvstore(i,j,k,ispec)
+
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
+
+! compute stress sigma
+
+ sigma(1,1) = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma(2,2) = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma(3,3) = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+
+ sigma(1,2) = mul*duxdyl_plus_duydxl
+ sigma(1,3) = mul*duzdxl_plus_duxdzl
+ sigma(2,3) = mul*duzdyl_plus_duydzl
+
+ endif
+
+ endif
+
+! define symmetric components of sigma for gravity
+ sigma(2,1) = sigma(1,2)
+ sigma(3,1) = sigma(1,3)
+ sigma(3,2) = sigma(2,3)
+
+
+
+end subroutine compute_stress_from_strain
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_coordinates_grid.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coordinates_grid.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_coordinates_grid.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_coordinates_grid.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_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/src/compute_coupling.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coupling.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_coupling.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_coupling.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,535 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_coupling_fluid_CMB(displ_crust_mantle,b_displ_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core,b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ SIMULATION_TYPE,nspec_top)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ displ_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_displ_crust_mantle
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+ integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
+
+ integer SIMULATION_TYPE
+ integer nspec_top
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n,nx,ny,nz,weight
+ integer :: i,j,k,k_corresp,ispec,ispec2D,iglob_cm,iglob_oc,ispec_selected
+
+
+ ! for surface elements exactly on the CMB
+ do ispec2D = 1,nspec_top !NSPEC2D_TOP(IREGION_OUTER_CORE)
+ ispec = ibelm_top_outer_core(ispec2D)
+
+ ! only for DOFs exactly on the CMB (top of these elements)
+ k = NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ ! get displacement on the solid side using pointwise matching
+ ispec_selected = ibelm_bottom_crust_mantle(ispec2D)
+
+ ! corresponding points are located at the bottom of the mantle
+ k_corresp = 1
+ iglob_cm = ibool_crust_mantle(i,j,k_corresp,ispec_selected)
+
+ displ_x = displ_crust_mantle(1,iglob_cm)
+ displ_y = displ_crust_mantle(2,iglob_cm)
+ displ_z = displ_crust_mantle(3,iglob_cm)
+
+ ! 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)
+
+ ! get global point number
+ iglob_oc = ibool_outer_core(i,j,k,ispec)
+
+ ! update fluid acceleration/pressure
+ accel_outer_core(iglob_oc) = accel_outer_core(iglob_oc) + weight*displ_n
+
+ if (SIMULATION_TYPE == 3) then
+ ! get displacement in crust mantle
+ iglob_cm = ibool_crust_mantle(i,j,k_corresp,ispec_selected)
+ displ_x = b_displ_crust_mantle(1,iglob_cm)
+ displ_y = b_displ_crust_mantle(2,iglob_cm)
+ displ_z = b_displ_crust_mantle(3,iglob_cm)
+
+ displ_n = displ_x*nx + displ_y*ny + displ_z*nz
+
+ ! update fluid acceleration/pressure
+ iglob_oc = ibool_outer_core(i,j,k,ispec)
+ b_accel_outer_core(iglob_oc) = b_accel_outer_core(iglob_oc) + weight*displ_n
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_coupling_fluid_CMB
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_coupling_fluid_ICB(displ_inner_core,b_displ_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ accel_outer_core,b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ SIMULATION_TYPE,nspec_bottom)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
+ displ_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
+ b_displ_inner_core
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+ integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+
+ integer SIMULATION_TYPE
+ integer nspec_bottom
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n,nx,ny,nz,weight
+ integer :: i,j,k,k_corresp,ispec,ispec2D,iglob_oc,iglob_ic,ispec_selected
+
+
+ ! for surface elements exactly on the ICB
+ do ispec2D = 1, nspec_bottom ! 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 displacement on the solid side using pointwise matching
+ ispec_selected = ibelm_top_inner_core(ispec2D)
+
+ ! corresponding points are located at the bottom of the mantle
+ k_corresp = NGLLZ
+ iglob_ic = ibool_inner_core(i,j,k_corresp,ispec_selected)
+
+ displ_x = displ_inner_core(1,iglob_ic)
+ displ_y = displ_inner_core(2,iglob_ic)
+ displ_z = displ_inner_core(3,iglob_ic)
+
+ ! 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)
+
+ ! get global point number
+ iglob_oc = ibool_outer_core(i,j,k,ispec)
+
+ ! update fluid acceleration/pressure
+ accel_outer_core(iglob_oc) = accel_outer_core(iglob_oc) - weight*displ_n
+
+ if (SIMULATION_TYPE == 3) then
+ ! get displacement in inner core
+ iglob_ic = ibool_inner_core(i,j,k_corresp,ispec_selected)
+ displ_x = b_displ_inner_core(1,iglob_ic)
+ displ_y = b_displ_inner_core(2,iglob_ic)
+ displ_z = b_displ_inner_core(3,iglob_ic)
+
+ displ_n = displ_x*nx + displ_y*ny + displ_z*nz
+
+
+ ! update fluid acceleration/pressure
+ iglob_oc = ibool_outer_core(i,j,k,ispec)
+ b_accel_outer_core(iglob_oc) = b_accel_outer_core(iglob_oc) - weight*displ_n
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_coupling_fluid_ICB
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine compute_coupling_CMB_fluid(displ_crust_mantle,b_displ_crust_mantle, &
+ accel_crust_mantle,b_accel_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core,b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ RHO_TOP_OC,minus_g_cmb, &
+ SIMULATION_TYPE,nspec_bottom)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ displ_crust_mantle,accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_displ_crust_mantle,b_accel_crust_mantle
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+ integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
+
+ double precision RHO_TOP_OC
+ real(kind=CUSTOM_REAL) minus_g_cmb
+
+ integer SIMULATION_TYPE
+ integer nspec_bottom
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: pressure,nx,ny,nz,weight
+ integer :: i,j,k,k_corresp,ispec,ispec2D,iglob_oc,iglob_mantle,ispec_selected
+
+
+ ! for surface elements exactly on the CMB
+ do ispec2D = 1,nspec_bottom ! 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_oc = ibool_outer_core(i,j,NGLLZ,ispec_selected)
+ iglob_mantle = ibool_crust_mantle(i,j,k,ispec)
+
+ ! compute pressure, taking gravity into account
+ if(GRAVITY_VAL) then
+ pressure = RHO_TOP_OC * (- accel_outer_core(iglob_oc) &
+ + minus_g_cmb *(displ_crust_mantle(1,iglob_mantle)*nx &
+ + displ_crust_mantle(2,iglob_mantle)*ny + displ_crust_mantle(3,iglob_mantle)*nz))
+ else
+ pressure = - RHO_TOP_OC * accel_outer_core(iglob_oc)
+ endif
+
+ ! 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
+
+ if (SIMULATION_TYPE == 3) then
+ if(GRAVITY_VAL) then
+ pressure = RHO_TOP_OC * (- b_accel_outer_core(iglob_oc) &
+ + minus_g_cmb *(b_displ_crust_mantle(1,iglob_mantle)*nx &
+ + b_displ_crust_mantle(2,iglob_mantle)*ny + b_displ_crust_mantle(3,iglob_mantle)*nz))
+ else
+ pressure = - RHO_TOP_OC * b_accel_outer_core(iglob_oc)
+ endif
+ b_accel_crust_mantle(1,iglob_mantle) = b_accel_crust_mantle(1,iglob_mantle) + weight*nx*pressure
+ b_accel_crust_mantle(2,iglob_mantle) = b_accel_crust_mantle(2,iglob_mantle) + weight*ny*pressure
+ b_accel_crust_mantle(3,iglob_mantle) = b_accel_crust_mantle(3,iglob_mantle) + weight*nz*pressure
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_coupling_CMB_fluid
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_coupling_ICB_fluid(displ_inner_core,b_displ_inner_core, &
+ accel_inner_core,b_accel_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ accel_outer_core,b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ RHO_BOTTOM_OC,minus_g_icb, &
+ SIMULATION_TYPE,nspec_top)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
+ displ_inner_core,accel_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
+ b_displ_inner_core,b_accel_inner_core
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+ integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+
+ double precision RHO_BOTTOM_OC
+ real(kind=CUSTOM_REAL) minus_g_icb
+
+ integer SIMULATION_TYPE
+ integer nspec_top
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: pressure,nx,ny,nz,weight
+ integer :: i,j,k,k_corresp,ispec,ispec2D,iglob,iglob_inner_core,ispec_selected
+
+ ! for surface elements exactly on the ICB
+ do ispec2D = 1,nspec_top ! 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
+ if(GRAVITY_VAL) then
+ pressure = RHO_BOTTOM_OC * (- accel_outer_core(iglob) &
+ + minus_g_icb *(displ_inner_core(1,iglob_inner_core)*nx &
+ + displ_inner_core(2,iglob_inner_core)*ny + displ_inner_core(3,iglob_inner_core)*nz))
+ else
+ pressure = - RHO_BOTTOM_OC * accel_outer_core(iglob)
+ endif
+
+ ! 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
+
+ if (SIMULATION_TYPE == 3) then
+ if(GRAVITY_VAL) then
+ pressure = RHO_BOTTOM_OC * (- b_accel_outer_core(iglob) &
+ + minus_g_icb *(b_displ_inner_core(1,iglob_inner_core)*nx &
+ + b_displ_inner_core(2,iglob_inner_core)*ny + b_displ_inner_core(3,iglob_inner_core)*nz))
+ else
+ pressure = - RHO_BOTTOM_OC * b_accel_outer_core(iglob)
+ endif
+ b_accel_inner_core(1,iglob_inner_core) = b_accel_inner_core(1,iglob_inner_core) - weight*nx*pressure
+ b_accel_inner_core(2,iglob_inner_core) = b_accel_inner_core(2,iglob_inner_core) - weight*ny*pressure
+ b_accel_inner_core(3,iglob_inner_core) = b_accel_inner_core(3,iglob_inner_core) - weight*nz*pressure
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_coupling_ICB_fluid
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_coupling_ocean(accel_crust_mantle,b_accel_crust_mantle, &
+ rmass_crust_mantle,rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load, &
+ SIMULATION_TYPE,nspec_top)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_accel_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+
+ logical, dimension(NGLOB_CRUST_MANTLE_OCEANS) :: updated_dof_ocean_load
+
+ integer SIMULATION_TYPE
+ integer nspec_top
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: force_normal_comp,b_force_normal_comp
+ real(kind=CUSTOM_REAL) :: additional_term,b_additional_term
+ real(kind=CUSTOM_REAL) :: nx,ny,nz
+ integer :: i,j,k,ispec,ispec2D,iglob
+
+ ! initialize the updates
+ updated_dof_ocean_load(:) = .false.
+
+ ! for surface elements exactly at the top of the crust (ocean bottom)
+ do ispec2D = 1,nspec_top !NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+
+ ispec = ibelm_top_crust_mantle(ispec2D)
+
+ ! only for DOFs exactly at the top of the crust (ocean bottom)
+ k = NGLLZ
+
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ ! get global point number
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+
+ ! only update once
+ if(.not. updated_dof_ocean_load(iglob)) then
+
+ ! get normal
+ nx = normal_top_crust_mantle(1,i,j,ispec2D)
+ ny = normal_top_crust_mantle(2,i,j,ispec2D)
+ nz = normal_top_crust_mantle(3,i,j,ispec2D)
+
+ ! make updated component of right-hand side
+ ! we divide by rmass_crust_mantle() which is 1 / M
+ ! we use the total force which includes the Coriolis term above
+ force_normal_comp = (accel_crust_mantle(1,iglob)*nx + &
+ accel_crust_mantle(2,iglob)*ny + &
+ accel_crust_mantle(3,iglob)*nz) / rmass_crust_mantle(iglob)
+
+ additional_term = (rmass_ocean_load(iglob) - rmass_crust_mantle(iglob)) * force_normal_comp
+
+ accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + additional_term * nx
+ accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + additional_term * ny
+ accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + additional_term * nz
+
+ if (SIMULATION_TYPE == 3) then
+ b_force_normal_comp = (b_accel_crust_mantle(1,iglob)*nx + &
+ b_accel_crust_mantle(2,iglob)*ny + &
+ b_accel_crust_mantle(3,iglob)*nz) / rmass_crust_mantle(iglob)
+
+ b_additional_term = (rmass_ocean_load(iglob) - rmass_crust_mantle(iglob)) * b_force_normal_comp
+
+ b_accel_crust_mantle(1,iglob) = b_accel_crust_mantle(1,iglob) + b_additional_term * nx
+ b_accel_crust_mantle(2,iglob) = b_accel_crust_mantle(2,iglob) + b_additional_term * ny
+ b_accel_crust_mantle(3,iglob) = b_accel_crust_mantle(3,iglob) + b_additional_term * nz
+ endif
+
+ ! done with this point
+ updated_dof_ocean_load(iglob) = .true.
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_coupling_ocean
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_element_properties.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_element_properties.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_element_properties.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_element_properties.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,297 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute several rheological and geometrical properties for a given spectral element
+ subroutine compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec,myrank,ABSORBING_CONDITIONS, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,nspec_actually, &
+ 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
+ rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
+ xigll,yigll,zigll)
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ !include "constants.h"
+
+! correct number of spectral elements in each block depending on chunk type
+ integer ispec,nspec,nspec_stacey
+
+ logical ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS
+
+ double precision RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,&
+ R400,R120,R80,RMIDDLE_CRUST,ROCEAN,RMOHO_FICTITIOUS_IN_MESHER
+
+! 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(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
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,dvpstore,kappavstore, &
+ kappahstore,muvstore,muhstore,eta_anisostore
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ integer nspec_ani
+ 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
+
+! arrays with mesh parameters
+ integer nspec_actually
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
+ 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
+ integer nspec_att
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
+ double precision, dimension(N_SLS) :: tau_s
+ double precision T_c_source
+
+ ! Parameters used to calculate Jacobian based upon 125 GLL points
+ double precision:: xigll(NGLLX)
+ double precision:: yigll(NGLLY)
+ double precision:: zigll(NGLLZ)
+
+ ! Parameter used to decide whether this element is in the crust or not
+ logical:: elem_in_crust,elem_in_mantle
+
+ ! add topography of the Moho *before* adding the 3D crustal velocity model so that the streched
+ ! mesh gets assigned the right model values
+ elem_in_crust = .false.
+ elem_in_mantle = .false.
+ if( iregion_code == IREGION_CRUST_MANTLE ) then
+ if( CRUSTAL .and. CASE_3D ) then
+ if( idoubling(ispec) == IFLAG_CRUST &
+ .or. idoubling(ispec) == IFLAG_220_80 &
+ .or. idoubling(ispec) == IFLAG_80_MOHO ) then
+ ! Stretch mesh to honor smoothed moho thickness from crust2.0
+
+ ! differentiate between regional and global meshing
+ if( REGIONAL_MOHO_MESH ) then
+ call moho_stretching_honor_crust_reg(myrank, &
+ xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
+ R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
+ else
+ call moho_stretching_honor_crust(myrank, &
+ xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
+ R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
+ endif
+ endif
+ endif
+ endif
+
+ ! interpolates and stores GLL point locations
+ call compute_element_GLL_locations(xelm,yelm,zelm,ispec,nspec, &
+ xstore,ystore,zstore,shape3D)
+
+
+ ! computes model's velocity/density/... values for the chosen Earth model
+ call get_model(myrank,iregion_code,ispec,nspec,idoubling(ispec), &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ rhostore,dvpstore,nspec_ani, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_stacey,rho_vp,rho_vs, &
+ xstore,ystore,zstore, &
+ rmin,rmax,RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220, &
+ R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ 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,elem_in_crust,elem_in_mantle)
+
+
+ ! either use GLL points or anchor points to capture TOPOGRAPHY and ELLIPTICITY
+ ! note: using gll points to capture them results in a slightly more accurate mesh.
+ ! however, it introduces more deformations to the elements which might lead to
+ ! problems with the jacobian. using the anchors is therefore more robust.
+ ! adds surface topography
+ if( TOPOGRAPHY ) then
+ if (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
+ .or. idoubling(ispec)==IFLAG_80_MOHO) then
+ ! stretches mesh between surface and R220 accordingly
+ if( USE_GLL ) then
+ ! stretches every gll point accordingly
+ call add_topography_gll(myrank,xstore,ystore,zstore,ispec,nspec,ibathy_topo,R220)
+ else
+ ! stretches anchor points only, interpolates gll points later on
+ call add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
+ endif
+ endif
+ endif
+
+ ! adds 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) then
+ if( USE_GLL ) then
+ ! stretches every gll point accordingly
+ call add_topography_410_650_gll(myrank,xstore,ystore,zstore,ispec,nspec,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)
+
+ else
+ ! stretches anchor points only, interpolates gll points later on
+ 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)
+ endif
+ endif
+
+ ! these are placeholders:
+ ! their corresponding subroutines subtopo_cmb() and subtopo_icb() are not implemented yet....
+ ! must be done/supplied by the user; uncomment in case
+ ! CMB topography
+ ! 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
+ ! 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) then
+ if( USE_GLL ) then
+ ! make the Earth's ellipticity, use GLL points
+ call get_ellipticity_gll(xstore,ystore,zstore,ispec,nspec,nspl,rspl,espl,espl2)
+ else
+ ! make the Earth's ellipticity, use element anchor points
+ call get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2)
+ endif
+ endif
+
+ ! re-interpolates and creates the GLL point locations since the anchor points might have moved
+ !
+ ! note: velocity values associated for each GLL point will "move" along together with
+ ! their associated points. however, we don't re-calculate the velocity model values since the
+ ! models are/should be referenced with respect to a spherical Earth.
+ if( .not. USE_GLL) &
+ call compute_element_GLL_locations(xelm,yelm,zelm,ispec,nspec, &
+ xstore,ystore,zstore,shape3D)
+
+ ! updates jacobian
+ call recalc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
+ ispec,nspec,ACTUALLY_STORE_ARRAYS,&
+ xixstore,xiystore,xizstore,&
+ etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore)
+
+ end subroutine compute_element_properties
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_element_GLL_locations(xelm,yelm,zelm,ispec,nspec, &
+ xstore,ystore,zstore,shape3D)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec,nspec
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ ! local parameters
+ double precision xmesh,ymesh,zmesh
+ integer i,j,k,ia
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+
+ ! interpolates the location using 3D shape functions
+ 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
+
+ ! stores 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 compute_element_GLL_locations
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_crust_mantle.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_crust_mantle.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_crust_mantle.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,955 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle,xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+!----------------------
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_INNER_CORE,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ ibool,idoubling,R_memory,epsilondev,epsilon_trace_over_3,one_minus_sum_beta, &
+ alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec)
+
+ 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"
+
+! model_attenuation_variables
+! type model_attenuation_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
+! 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, dimension(:), pointer :: interval_Q ! Steps
+! integer :: Qn ! Number of points
+! integer dummy_pad ! padding 4 bytes to align the structure
+! end type model_attenuation_variables
+
+! 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_crust_mantle,accel_crust_mantle
+
+! 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
+
+! 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(NGLLX, NGLLY, NGLLZ) :: factor_common_c44_muv
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilon_trace_over_3
+
+! 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
+
+! arrays for full anisotropy only when needed
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store
+
+ integer ispec,iglob,ispec_strain
+ 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
+ integer int_radius
+ real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
+ double precision radius,rho,minus_g,minus_dg
+ double precision minus_g_over_radius,minus_dg_plus_g_over_radius
+ double precision cos_theta,sin_theta,cos_phi,sin_phi
+ double precision cos_theta_sq,sin_theta_sq,cos_phi_sq,sin_phi_sq
+ double precision factor,sx_l,sy_l,sz_l,gxl,gyl,gzl
+ double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
+ double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+! this for non blocking MPI
+ integer :: iphase,icall
+
+ integer :: computed_elements
+
+ logical, dimension(NSPEC_CRUST_MANTLE) :: is_on_a_slice_edge_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: accel_inner_core
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+
+ integer :: ichunk,iproc_xi,iproc_eta,myrank
+
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+
+ 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
+
+ integer npoin2D_faces_crust_mantle(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_inner_core,npoin2D_eta_inner_core
+
+! 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(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
+
+ integer :: npoin2D_max_all_CM_IC
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
+
+! 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_chunkcorn_vector,buffer_recv_chunkcorn_vector
+
+! for matching with central cube in inner core
+ integer nb_msgs_theor_in_cube, npoin2D_cube_from_slices,iphase_CC
+ integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
+ double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices
+ double precision, dimension(npoin2D_cube_from_slices,NDIM,nb_msgs_theor_in_cube) :: buffer_all_cube_from_slices
+ integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
+ integer receiver_cube_from_slices
+ logical :: INCLUDE_CENTRAL_CUBE
+
+! local to global mapping
+ integer NSPEC2D_BOTTOM_INNER_CORE
+ integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
+
+! ****************************************************
+! big loop over all spectral elements in the solid
+! ****************************************************
+
+ computed_elements = 0
+
+ do ispec = 1,NSPEC_CRUST_MANTLE
+
+! hide communications by computing the edges first
+ if((icall == 2 .and. is_on_a_slice_edge_crust_mantle(ispec)) .or. &
+ (icall == 1 .and. .not. is_on_a_slice_edge_crust_mantle(ispec))) cycle
+
+! process the communications every ELEMENTS_NONBLOCKING elements
+ computed_elements = computed_elements + 1
+ if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_CM_IC) == 0) then
+
+ if(iphase <= 7) call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_CM, &
+ NGLOB1D_RADIAL_IC,NCHUNKS_VAL,iphase)
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ if(iphase > 7 .and. iphase_CC <= 4) &
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,accel_inner_core,NDIM,iphase_CC)
+ endif
+
+ endif
+
+ 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_crust_mantle(1,iglob)*hp1
+ tempy1l = tempy1l + displ_crust_mantle(2,iglob)*hp1
+ tempz1l = tempz1l + displ_crust_mantle(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_crust_mantle(1,iglob)*hp2
+ tempy2l = tempy2l + displ_crust_mantle(2,iglob)*hp2
+ tempz2l = tempz2l + displ_crust_mantle(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_crust_mantle(1,iglob)*hp3
+ tempy3l = tempy3l + displ_crust_mantle(2,iglob)*hp3
+ tempz3l = tempz3l + displ_crust_mantle(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
+ if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
+ ispec_strain = 1
+ else
+ ispec_strain = ispec
+ endif
+ epsilon_trace_over_3(i,j,k,ispec_strain) = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(1,i,j,k) = duxdxl - epsilon_trace_over_3(i,j,k,ispec_strain)
+ epsilondev_loc(2,i,j,k) = duydyl - epsilon_trace_over_3(i,j,k,ispec_strain)
+ epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
+ endif
+
+ ! precompute terms for attenuation if needed
+ if(ATTENUATION_VAL) then
+ one_minus_sum_beta_use = one_minus_sum_beta(i,j,k,ispec)
+ minus_sum_beta = one_minus_sum_beta_use - 1.0
+ endif
+
+ !
+ ! compute either isotropic or anisotropic elements
+ !
+
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+
+ c11 = c11store(i,j,k,ispec)
+ c12 = c12store(i,j,k,ispec)
+ c13 = c13store(i,j,k,ispec)
+ c14 = c14store(i,j,k,ispec)
+ c15 = c15store(i,j,k,ispec)
+ c16 = c16store(i,j,k,ispec)
+ c22 = c22store(i,j,k,ispec)
+ c23 = c23store(i,j,k,ispec)
+ c24 = c24store(i,j,k,ispec)
+ c25 = c25store(i,j,k,ispec)
+ c26 = c26store(i,j,k,ispec)
+ c33 = c33store(i,j,k,ispec)
+ c34 = c34store(i,j,k,ispec)
+ c35 = c35store(i,j,k,ispec)
+ c36 = c36store(i,j,k,ispec)
+ c44 = c44store(i,j,k,ispec)
+ c45 = c45store(i,j,k,ispec)
+ c46 = c46store(i,j,k,ispec)
+ c55 = c55store(i,j,k,ispec)
+ c56 = c56store(i,j,k,ispec)
+ c66 = c66store(i,j,k,ispec)
+
+ if(ATTENUATION_VAL) then
+ mul = c44
+ c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
+ c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
+ c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
+ c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
+ c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
+ c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
+ c44 = c44 + minus_sum_beta * mul
+ c55 = c55 + minus_sum_beta * mul
+ c66 = c66 + minus_sum_beta * mul
+ endif
+
+ 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
+
+ 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 .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) 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
+
+ ! define symmetric components of sigma for gravity
+ sigma_yx = sigma_xy
+ sigma_zx = sigma_xz
+ sigma_zy = sigma_yz
+
+ ! compute non-symmetric terms for gravity
+ if(GRAVITY_VAL) then
+
+ ! use mesh coordinates to get theta and phi
+ ! x y and z contain r theta and phi
+
+ iglob = ibool(i,j,k,ispec)
+ radius = dble(xstore(iglob))
+ theta = ystore(iglob)
+ phi = zstore(iglob)
+
+ cos_theta = dcos(dble(theta))
+ sin_theta = dsin(dble(theta))
+ cos_phi = dcos(dble(phi))
+ sin_phi = dsin(dble(phi))
+
+ ! get g, rho and dg/dr=dg
+ ! spherical components of the gravitational acceleration
+ ! for efficiency replace with lookup table every 100 m in radial direction
+ int_radius = nint(radius * R_EARTH_KM * 10.d0)
+ minus_g = minus_gravity_table(int_radius)
+ minus_dg = minus_deriv_gravity_table(int_radius)
+ rho = density_table(int_radius)
+
+ ! Cartesian components of the gravitational acceleration
+ gxl = minus_g*sin_theta*cos_phi
+ gyl = minus_g*sin_theta*sin_phi
+ gzl = minus_g*cos_theta
+
+ ! Cartesian components of gradient of gravitational acceleration
+ ! obtained from spherical components
+
+ minus_g_over_radius = minus_g / radius
+ minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
+
+ cos_theta_sq = cos_theta**2
+ sin_theta_sq = sin_theta**2
+ cos_phi_sq = cos_phi**2
+ sin_phi_sq = sin_phi**2
+
+ Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
+ Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
+ Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
+ Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
+ Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
+ Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
+
+ iglob = ibool(i,j,k,ispec)
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+ ! get displacement and multiply by density to compute G tensor
+ sx_l = rho * dble(displ_crust_mantle(1,iglob))
+ sy_l = rho * dble(displ_crust_mantle(2,iglob))
+ sz_l = rho * dble(displ_crust_mantle(3,iglob))
+
+ ! compute G tensor from s . g and add to sigma (not symmetric)
+ sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
+ sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
+ sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
+
+ sigma_xy = sigma_xy - sngl(sx_l * gyl)
+ sigma_yx = sigma_yx - sngl(sy_l * gxl)
+
+ sigma_xz = sigma_xz - sngl(sx_l * gzl)
+ sigma_zx = sigma_zx - sngl(sz_l * gxl)
+
+ sigma_yz = sigma_yz - sngl(sy_l * gzl)
+ sigma_zy = sigma_zy - sngl(sz_l * gyl)
+
+ ! precompute vector
+ factor = dble(jacobianl) * wgll_cube(i,j,k)
+ rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
+ rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
+ rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
+
+ else
+
+ ! get displacement and multiply by density to compute G tensor
+ sx_l = rho * displ_crust_mantle(1,iglob)
+ sy_l = rho * displ_crust_mantle(2,iglob)
+ sz_l = rho * displ_crust_mantle(3,iglob)
+
+ ! compute G tensor from s . g and add to sigma (not symmetric)
+ sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
+ sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
+ sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
+
+ sigma_xy = sigma_xy - sx_l * gyl
+ sigma_yx = sigma_yx - sy_l * gxl
+
+ sigma_xz = sigma_xz - sx_l * gzl
+ sigma_zx = sigma_zx - sz_l * gxl
+
+ sigma_yz = sigma_yz - sy_l * gzl
+ sigma_zy = sigma_zy - sz_l * gyl
+
+ ! precompute vector
+ factor = jacobianl * wgll_cube(i,j,k)
+ rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
+ rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
+ rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
+
+ endif
+
+ endif ! end of section with gravity terms
+
+ ! form dot product with test vector, non-symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo ! NGLLX
+ enddo ! NGLLY
+ enddo ! NGLLZ
+
+ 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)
+
+ if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
+
+ enddo ! NGLLX
+ enddo ! NGLLY
+ enddo ! NGLLZ
+
+! sum contributions from each element to the global mesh and add gravity terms
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + sum_terms(1,i,j,k)
+ accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + sum_terms(2,i,j,k)
+ accel_crust_mantle(3,iglob) = accel_crust_mantle(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
+! This is because we only implement Q_\mu attenuation and not Q_\kappa.
+! Note that this does *NOT* imply that there is no attenuation for P waves
+! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
+! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
+! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
+! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
+
+ if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. )) 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
+
+ ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
+ factor_common_c44_muv = factor_common(i_SLS,:,:,:,ispec)
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+ factor_common_c44_muv = factor_common_c44_muv * c44store(:,:,:,ispec)
+ else
+ factor_common_c44_muv = factor_common_c44_muv * muvstore(:,:,:,ispec)
+ endif
+
+ R_memory(i_memory,i_SLS,:,:,:,ispec) = alphaval(i_SLS) * &
+ R_memory(i_memory,i_SLS,:,:,:,ispec) + &
+ factor_common_c44_muv * &
+ (betaval(i_SLS) * epsilondev(i_memory,:,:,:,ispec) + &
+ gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
+ enddo
+ enddo
+
+ endif
+
+! save deviatoric strain for Runge-Kutta scheme
+ if(COMPUTE_AND_STORE_STRAIN) then
+ !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ epsilondev(:,i,j,k,ispec) = epsilondev_loc(:,i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+
+ enddo ! spectral element loop NSPEC_CRUST_MANTLE
+
+ end subroutine compute_forces_crust_mantle
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_crust_mantle_Dev.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle_Dev.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_crust_mantle_Dev.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_crust_mantle_Dev.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1155 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle,xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+!----------------------
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_INNER_CORE,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ ibool,idoubling,R_memory,epsilondev,epsilon_trace_over_3,one_minus_sum_beta, &
+ alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec)
+
+! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
+
+ 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(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle,accel_crust_mantle
+ ! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool
+
+ ! 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,NSPEC_CRUST_MANTLE) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+ ! array with derivatives of Lagrange polynomials and precalculated products
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ ! store anisotropic properties only where needed to save memory
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ kappahstore,muhstore,eta_anisostore
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
+ kappavstore,muvstore
+
+ ! arrays for full anisotropy only when needed
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store
+
+ ! attenuation
+ ! memory variables for attenuation
+ ! memory variables R_ij are stored at the local rather than global level
+ ! to allow for optimization of cache access by compiler
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilon_trace_over_3
+
+ integer vx,vy,vz,vnspec
+
+ ! [alpha,beta,gamma]val reduced to N_SLS and factor_common to N_SLS*NUM_NODES
+ real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: factor_common
+ real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
+
+ ! array with the local to global mapping per slice
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling
+
+ ! gravity
+ double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
+
+! local parameters
+ ! Deville
+ ! manually inline the calls to the Deville et al. (2002) routines
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
+ newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: E1_m1_m2_5points,E2_m1_m2_5points,E3_m1_m2_5points
+
+ equivalence(dummyx_loc,B1_m1_m2_5points)
+ equivalence(dummyy_loc,B2_m1_m2_5points)
+ equivalence(dummyz_loc,B3_m1_m2_5points)
+ equivalence(tempx1,C1_m1_m2_5points)
+ equivalence(tempy1,C2_m1_m2_5points)
+ equivalence(tempz1,C3_m1_m2_5points)
+ equivalence(newtempx1,E1_m1_m2_5points)
+ equivalence(newtempy1,E2_m1_m2_5points)
+ equivalence(newtempz1,E3_m1_m2_5points)
+
+ real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: &
+ A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ E1_mxm_m2_m1_5points,E2_mxm_m2_m1_5points,E3_mxm_m2_m1_5points
+
+ equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
+ equivalence(dummyy_loc,A2_mxm_m2_m1_5points)
+ equivalence(dummyz_loc,A3_mxm_m2_m1_5points)
+ equivalence(tempx3,C1_mxm_m2_m1_5points)
+ equivalence(tempy3,C2_mxm_m2_m1_5points)
+ equivalence(tempz3,C3_mxm_m2_m1_5points)
+ equivalence(newtempx3,E1_mxm_m2_m1_5points)
+ equivalence(newtempy3,E2_mxm_m2_m1_5points)
+ equivalence(newtempz3,E3_mxm_m2_m1_5points)
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
+
+ ! for attenuation
+ real(kind=CUSTOM_REAL), dimension(NGLLX, NGLLY, NGLLZ) :: &
+ factor_common_c44_muv
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+ real(kind=CUSTOM_REAL) R_xx_val1,R_yy_val1,R_xx_val2,R_yy_val2,R_xx_val3,R_yy_val3
+ real(kind=CUSTOM_REAL) one_minus_sum_beta_use,minus_sum_beta
+
+ ! 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) fac1,fac2,fac3,templ
+ real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) kappal,kappavl,kappahl,muvl,muhl
+
+ ! for gravity
+ double precision radius,rho,minus_g,minus_dg
+ double precision minus_g_over_radius,minus_dg_plus_g_over_radius
+ double precision cos_theta,sin_theta,cos_phi,sin_phi
+ double precision cos_theta_sq,sin_theta_sq,cos_phi_sq,sin_phi_sq
+ double precision factor,sx_l,sy_l,sz_l,gxl,gyl,gzl
+ double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
+ real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
+
+ integer :: i_SLS,i_memory,imodulo_N_SLS
+ integer :: ispec,ispec_strain
+ integer :: i,j,k
+ integer :: int_radius
+ integer :: iglob1,iglob2,iglob3,iglob4,iglob5
+
+! this for non blocking MPI
+ integer :: iphase,icall
+
+ integer :: computed_elements
+
+ logical, dimension(NSPEC_CRUST_MANTLE) :: is_on_a_slice_edge_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: accel_inner_core
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+
+ integer :: ichunk,iproc_xi,iproc_eta,myrank
+
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+
+ 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
+
+ integer npoin2D_faces_crust_mantle(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_inner_core,npoin2D_eta_inner_core
+
+! 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(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
+
+ integer :: npoin2D_max_all_CM_IC
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
+
+! 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_chunkcorn_vector,buffer_recv_chunkcorn_vector
+
+! for matching with central cube in inner core
+ integer nb_msgs_theor_in_cube, npoin2D_cube_from_slices,iphase_CC
+ integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
+ double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices
+ double precision, dimension(npoin2D_cube_from_slices,NDIM,nb_msgs_theor_in_cube) :: buffer_all_cube_from_slices
+ integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
+ integer receiver_cube_from_slices
+ logical :: INCLUDE_CENTRAL_CUBE
+
+! local to global mapping
+ integer NSPEC2D_BOTTOM_INNER_CORE
+ integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
+
+! ****************************************************
+! big loop over all spectral elements in the solid
+! ****************************************************
+
+ imodulo_N_SLS = mod(N_SLS,3)
+
+ computed_elements = 0
+
+ do ispec = 1,NSPEC_CRUST_MANTLE
+
+! hide communications by computing the edges first
+ if((icall == 2 .and. is_on_a_slice_edge_crust_mantle(ispec)) .or. &
+ (icall == 1 .and. .not. is_on_a_slice_edge_crust_mantle(ispec))) cycle
+
+! process the communications every ELEMENTS_NONBLOCKING elements
+ computed_elements = computed_elements + 1
+ if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_CM_IC) == 0) then
+
+ if(iphase <= 7) call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_CM, &
+ NGLOB1D_RADIAL_IC,NCHUNKS_VAL,iphase)
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ if(iphase > 7 .and. iphase_CC <= 4) &
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,accel_inner_core,NDIM,iphase_CC)
+ endif
+
+ endif
+
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! for incompressible fluid flow, Cambridge University Press (2002),
+ ! pages 386 and 389 and Figure 8.3.1
+ do k=1,NGLLZ
+ do j=1,NGLLY
+
+! way 1:
+! do i=1,NGLLX
+! iglob = ibool(i,j,k,ispec)
+! dummyx_loc(i,j,k) = displ_crust_mantle(1,iglob)
+! dummyy_loc(i,j,k) = displ_crust_mantle(2,iglob)
+! dummyz_loc(i,j,k) = displ_crust_mantle(3,iglob)
+! enddo
+
+! way 2:
+ ! since we know that NGLLX = 5, this should help pipelining
+ iglob1 = ibool(1,j,k,ispec)
+ iglob2 = ibool(2,j,k,ispec)
+ iglob3 = ibool(3,j,k,ispec)
+ iglob4 = ibool(4,j,k,ispec)
+ iglob5 = ibool(5,j,k,ispec)
+
+ dummyx_loc(1,j,k) = displ_crust_mantle(1,iglob1)
+ dummyy_loc(1,j,k) = displ_crust_mantle(2,iglob1)
+ dummyz_loc(1,j,k) = displ_crust_mantle(3,iglob1)
+
+ dummyx_loc(2,j,k) = displ_crust_mantle(1,iglob2)
+ dummyy_loc(2,j,k) = displ_crust_mantle(2,iglob2)
+ dummyz_loc(2,j,k) = displ_crust_mantle(3,iglob2)
+
+ dummyx_loc(3,j,k) = displ_crust_mantle(1,iglob3)
+ dummyy_loc(3,j,k) = displ_crust_mantle(2,iglob3)
+ dummyz_loc(3,j,k) = displ_crust_mantle(3,iglob3)
+
+ dummyx_loc(4,j,k) = displ_crust_mantle(1,iglob4)
+ dummyy_loc(4,j,k) = displ_crust_mantle(2,iglob4)
+ dummyz_loc(4,j,k) = displ_crust_mantle(3,iglob4)
+
+ dummyx_loc(5,j,k) = displ_crust_mantle(1,iglob5)
+ dummyy_loc(5,j,k) = displ_crust_mantle(2,iglob5)
+ dummyz_loc(5,j,k) = displ_crust_mantle(3,iglob5)
+
+ enddo
+ enddo
+ do j=1,m2
+ do i=1,m1
+ C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B1_m1_m2_5points(5,j)
+
+ C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B2_m1_m2_5points(5,j)
+
+ C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B3_m1_m2_5points(5,j)
+ enddo
+ enddo
+ do j=1,m1
+ do i=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyx_loc(i,5,k)*hprime_xxT(5,j)
+
+ tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyy_loc(i,5,k)*hprime_xxT(5,j)
+
+ tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ enddo
+ enddo
+ enddo
+ do j=1,m1
+ do i=1,m2
+ C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+
+ C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+
+ C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+ ! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ duxdxl = xixl*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
+ duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
+ duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
+
+ duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
+ duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
+ duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
+
+ duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
+ duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
+ duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
+
+ ! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
+
+ ! compute deviatoric strain
+ if (COMPUTE_AND_STORE_STRAIN) then
+ if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
+ ispec_strain = 1
+ else
+ ispec_strain = ispec
+ endif
+ templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilon_trace_over_3(i,j,k,ispec_strain) = templ
+ epsilondev_loc(1,i,j,k) = duxdxl - templ
+ epsilondev_loc(2,i,j,k) = duydyl - templ
+ epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
+ 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
+ one_minus_sum_beta_use = one_minus_sum_beta(i,j,k,ispec)
+ minus_sum_beta = one_minus_sum_beta_use - 1.0
+ endif
+
+ !
+ ! compute either isotropic or anisotropic elements
+ !
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+
+ c11 = c11store(i,j,k,ispec)
+ c12 = c12store(i,j,k,ispec)
+ c13 = c13store(i,j,k,ispec)
+ c14 = c14store(i,j,k,ispec)
+ c15 = c15store(i,j,k,ispec)
+ c16 = c16store(i,j,k,ispec)
+ c22 = c22store(i,j,k,ispec)
+ c23 = c23store(i,j,k,ispec)
+ c24 = c24store(i,j,k,ispec)
+ c25 = c25store(i,j,k,ispec)
+ c26 = c26store(i,j,k,ispec)
+ c33 = c33store(i,j,k,ispec)
+ c34 = c34store(i,j,k,ispec)
+ c35 = c35store(i,j,k,ispec)
+ c36 = c36store(i,j,k,ispec)
+ c44 = c44store(i,j,k,ispec)
+ c45 = c45store(i,j,k,ispec)
+ c46 = c46store(i,j,k,ispec)
+ c55 = c55store(i,j,k,ispec)
+ c56 = c56store(i,j,k,ispec)
+ c66 = c66store(i,j,k,ispec)
+
+ if(ATTENUATION_VAL) then
+ mul = c44
+ c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
+ c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
+ c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
+ c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
+ c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
+ c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
+ c44 = c44 + minus_sum_beta * mul
+ c55 = c55 + minus_sum_beta * mul
+ c66 = c66 + minus_sum_beta * mul
+ endif
+
+ 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
+
+ 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
+
+! note : mesh is built such that anisotropic elements are created first in anisotropic layers,
+! thus they are listed first ( see in create_regions_mesh.f90: perm_layer() ordering )
+! this is therefore still in bounds of 1:NSPECMAX_TISO_MANTLE even if NSPECMAX_TISO is less than NSPEC
+
+ ! uncomment to debug
+ !if ( ispec > NSPECMAX_TISO_MANTLE ) then
+ ! print*,'error tiso: ispec = ',ispec,'max = ',NSPECMAX_TISO_MANTLE
+ ! call exit_mpi(0,'error tiso ispec bounds')
+ !endif
+
+ ! 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
+
+ iglob1 = ibool(i,j,k,ispec)
+ theta = ystore(iglob1)
+ phi = zstore(iglob1)
+
+ 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 .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) then
+! way 1:
+! 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
+
+! way 2:
+! note: this should help compilers to pipeline the code and make better use of the cache;
+! depending on compilers, it can further decrease the computation time by ~ 30%.
+! by default, N_SLS = 3, therefore we take steps of 3
+ if(imodulo_N_SLS >= 1) then
+ do i_SLS = 1,imodulo_N_SLS
+ R_xx_val1 = R_memory(1,i_SLS,i,j,k,ispec)
+ R_yy_val1 = R_memory(2,i_SLS,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val1
+ sigma_yy = sigma_yy - R_yy_val1
+ sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
+ sigma_xy = sigma_xy - R_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
+
+ if(N_SLS >= imodulo_N_SLS+1) then
+ do i_SLS = imodulo_N_SLS+1,N_SLS,3
+ R_xx_val1 = R_memory(1,i_SLS,i,j,k,ispec)
+ R_yy_val1 = R_memory(2,i_SLS,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val1
+ sigma_yy = sigma_yy - R_yy_val1
+ sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
+ sigma_xy = sigma_xy - R_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)
+
+ R_xx_val2 = R_memory(1,i_SLS+1,i,j,k,ispec)
+ R_yy_val2 = R_memory(2,i_SLS+1,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val2
+ sigma_yy = sigma_yy - R_yy_val2
+ sigma_zz = sigma_zz + R_xx_val2 + R_yy_val2
+ sigma_xy = sigma_xy - R_memory(3,i_SLS+1,i,j,k,ispec)
+ sigma_xz = sigma_xz - R_memory(4,i_SLS+1,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_memory(5,i_SLS+1,i,j,k,ispec)
+
+ R_xx_val3 = R_memory(1,i_SLS+2,i,j,k,ispec)
+ R_yy_val3 = R_memory(2,i_SLS+2,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val3
+ sigma_yy = sigma_yy - R_yy_val3
+ sigma_zz = sigma_zz + R_xx_val3 + R_yy_val3
+ sigma_xy = sigma_xy - R_memory(3,i_SLS+2,i,j,k,ispec)
+ sigma_xz = sigma_xz - R_memory(4,i_SLS+2,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_memory(5,i_SLS+2,i,j,k,ispec)
+ enddo
+ endif
+
+ endif
+
+ ! define symmetric components of sigma for gravity
+ sigma_yx = sigma_xy
+ sigma_zx = sigma_xz
+ sigma_zy = sigma_yz
+
+ ! compute non-symmetric terms for gravity
+ if(GRAVITY_VAL) then
+
+ ! use mesh coordinates to get theta and phi
+ ! x y and z contain r theta and phi
+ iglob1 = ibool(i,j,k,ispec)
+ theta = ystore(iglob1)
+ phi = zstore(iglob1)
+
+ cos_theta = dcos(dble(theta))
+ sin_theta = dsin(dble(theta))
+ cos_phi = dcos(dble(phi))
+ sin_phi = dsin(dble(phi))
+
+ cos_theta_sq = cos_theta**2
+ sin_theta_sq = sin_theta**2
+ cos_phi_sq = cos_phi**2
+ sin_phi_sq = sin_phi**2
+
+ ! get g, rho and dg/dr=dg
+ ! spherical components of the gravitational acceleration
+ ! for efficiency replace with lookup table every 100 m in radial direction
+ radius = dble(xstore(iglob1))
+ int_radius = nint(radius * R_EARTH_KM * 10.d0)
+ minus_g = minus_gravity_table(int_radius)
+ minus_dg = minus_deriv_gravity_table(int_radius)
+ rho = density_table(int_radius)
+
+ ! Cartesian components of the gravitational acceleration
+ gxl = minus_g*sin_theta*cos_phi
+ gyl = minus_g*sin_theta*sin_phi
+ gzl = minus_g*cos_theta
+
+ ! Cartesian components of gradient of gravitational acceleration
+ ! obtained from spherical components
+ minus_g_over_radius = minus_g / radius
+ minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
+
+ Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
+ Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
+ Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
+ Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
+ Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
+ Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
+
+
+ ! for locality principle, we set iglob again, in order to have it in the cache again
+ iglob1 = ibool(i,j,k,ispec)
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+ ! get displacement and multiply by density to compute G tensor
+ sx_l = rho * dble(displ_crust_mantle(1,iglob1))
+ sy_l = rho * dble(displ_crust_mantle(2,iglob1))
+ sz_l = rho * dble(displ_crust_mantle(3,iglob1))
+
+ ! compute G tensor from s . g and add to sigma (not symmetric)
+ sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
+ sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
+ sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
+
+ sigma_xy = sigma_xy - sngl(sx_l * gyl)
+ sigma_yx = sigma_yx - sngl(sy_l * gxl)
+
+ sigma_xz = sigma_xz - sngl(sx_l * gzl)
+ sigma_zx = sigma_zx - sngl(sz_l * gxl)
+
+ sigma_yz = sigma_yz - sngl(sy_l * gzl)
+ sigma_zy = sigma_zy - sngl(sz_l * gyl)
+
+ ! precompute vector
+ factor = dble(jacobianl) * wgll_cube(i,j,k)
+ rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
+ rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
+ rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
+
+ else
+
+ ! get displacement and multiply by density to compute G tensor
+ sx_l = rho * displ_crust_mantle(1,iglob1)
+ sy_l = rho * displ_crust_mantle(2,iglob1)
+ sz_l = rho * displ_crust_mantle(3,iglob1)
+
+ ! compute G tensor from s . g and add to sigma (not symmetric)
+ sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
+ sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
+ sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
+
+ sigma_xy = sigma_xy - sx_l * gyl
+ sigma_yx = sigma_yx - sy_l * gxl
+
+ sigma_xz = sigma_xz - sx_l * gzl
+ sigma_zx = sigma_zx - sz_l * gxl
+
+ sigma_yz = sigma_yz - sy_l * gzl
+ sigma_zy = sigma_zy - sz_l * gyl
+
+ ! precompute vector
+ factor = jacobianl * wgll_cube(i,j,k)
+ rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
+ rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
+ rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
+
+ endif
+
+ endif ! end of section with gravity terms
+
+ ! form dot product with test vector, non-symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+ enddo ! NGLLX
+ enddo ! NGLLY
+ enddo ! NGLLZ
+
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! for incompressible fluid flow, Cambridge University Press (2002),
+ ! pages 386 and 389 and Figure 8.3.1
+ do j=1,m2
+ do i=1,m1
+ E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
+
+ E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
+
+ E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
+ enddo
+ enddo
+ do i=1,m1
+ do j=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempx2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempx2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempx2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempx2(i,5,k)*hprimewgll_xx(5,j)
+
+ newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempy2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempy2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempy2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempy2(i,5,k)*hprimewgll_xx(5,j)
+
+ newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempz2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempz2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempz2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempz2(i,5,k)*hprimewgll_xx(5,j)
+ enddo
+ enddo
+ enddo
+ do j=1,m1
+ do i=1,m2
+ E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+
+ E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+
+ E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+
+! way 1:
+! this seems to be still the fastest way here.
+ fac1 = wgllwgll_yz(j,k)
+ do i=1,NGLLX
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+
+ ! sum contributions
+ sum_terms(1,i,j,k) = - (fac1*newtempx1(i,j,k) + fac2*newtempx2(i,j,k) + fac3*newtempx3(i,j,k))
+ sum_terms(2,i,j,k) = - (fac1*newtempy1(i,j,k) + fac2*newtempy2(i,j,k) + fac3*newtempy3(i,j,k))
+ sum_terms(3,i,j,k) = - (fac1*newtempz1(i,j,k) + fac2*newtempz2(i,j,k) + fac3*newtempz3(i,j,k))
+
+ if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
+
+ enddo ! NGLLX
+
+ enddo ! NGLLY
+ enddo ! NGLLZ
+
+ ! sum contributions from each element to the global mesh and add gravity terms
+ do k=1,NGLLZ
+ do j=1,NGLLY
+! way 1:
+! do i=1,NGLLX
+! iglob = ibool(i,j,k,ispec)
+! accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) + sum_terms(:,i,j,k)
+! enddo
+
+! way 2:
+ accel_crust_mantle(:,ibool(1,j,k,ispec)) = accel_crust_mantle(:,ibool(1,j,k,ispec)) + sum_terms(:,1,j,k)
+ accel_crust_mantle(:,ibool(2,j,k,ispec)) = accel_crust_mantle(:,ibool(2,j,k,ispec)) + sum_terms(:,2,j,k)
+ accel_crust_mantle(:,ibool(3,j,k,ispec)) = accel_crust_mantle(:,ibool(3,j,k,ispec)) + sum_terms(:,3,j,k)
+ accel_crust_mantle(:,ibool(4,j,k,ispec)) = accel_crust_mantle(:,ibool(4,j,k,ispec)) + sum_terms(:,4,j,k)
+ accel_crust_mantle(:,ibool(5,j,k,ispec)) = accel_crust_mantle(:,ibool(5,j,k,ispec)) + sum_terms(:,5,j,k)
+
+ 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
+ ! This is because we only implement Q_\mu attenuation and not Q_\kappa.
+ ! Note that this does *NOT* imply that there is no attenuation for P waves
+ ! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
+ ! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
+ ! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
+ ! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
+
+ if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) then
+
+ ! use Runge-Kutta scheme to march in time
+
+ ! get coefficients for that standard linear solid
+ ! IMPROVE we use mu_v here even if there is some anisotropy
+ ! IMPROVE we should probably use an average value instead
+
+! way 1:
+! it still seems to be the fastest way here.
+ do i_SLS = 1,N_SLS
+ ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
+ factor_common_c44_muv = factor_common(i_SLS,:,:,:,ispec)
+
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+ factor_common_c44_muv = factor_common_c44_muv * c44store(:,:,:,ispec)
+ else
+ factor_common_c44_muv = factor_common_c44_muv * muvstore(:,:,:,ispec)
+ endif
+
+ do i_memory = 1,5
+ R_memory(i_memory,i_SLS,:,:,:,ispec) = alphaval(i_SLS) * &
+ R_memory(i_memory,i_SLS,:,:,:,ispec) + &
+ factor_common_c44_muv * &
+ (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) then
+! way 1:
+ !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
+! way 2:
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ !dummy(:) = epsilondev_loc(:,1,j,k)
+
+ epsilondev(:,1,j,k,ispec) = epsilondev_loc(:,1,j,k)
+ epsilondev(:,2,j,k,ispec) = epsilondev_loc(:,2,j,k)
+ epsilondev(:,3,j,k,ispec) = epsilondev_loc(:,3,j,k)
+ epsilondev(:,4,j,k,ispec) = epsilondev_loc(:,4,j,k)
+ epsilondev(:,5,j,k,ispec) = epsilondev_loc(:,5,j,k)
+ enddo
+ enddo
+ endif
+
+ enddo ! spectral element loop NSPEC_CRUST_MANTLE
+
+ end subroutine compute_forces_crust_mantle_Dev
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_inner_core.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_inner_core.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_inner_core.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,682 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core,xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+!----------------------
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_INNER_CORE,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore,muvstore,ibool,idoubling, &
+ c11store,c33store,c12store,c13store,c44store,R_memory,epsilondev,epsilon_trace_over_3,&
+ one_minus_sum_beta,alphaval,betaval,gammaval,factor_common, &
+ vx,vy,vz,vnspec)
+
+ 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(NDIM,NGLOB_INNER_CORE) :: displ_inner_core,accel_inner_core
+
+! 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(NGLLX, NGLLY, NGLLZ) :: factor_common_use
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilon_trace_over_3
+
+! 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
+
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
+! c11store,c33store,c12store,c13store,c44store
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
+ c11store,c33store,c12store,c13store,c44store
+
+ integer ispec,iglob,ispec_strain
+ integer i,j,k,l
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+
+ 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) c11l,c33l,c12l,c13l,c44l
+
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+
+! for gravity
+ integer int_radius
+ real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
+ double precision radius,rho,minus_g,minus_dg
+ double precision minus_g_over_radius,minus_dg_plus_g_over_radius
+ double precision cos_theta,sin_theta,cos_phi,sin_phi
+ double precision cos_theta_sq,sin_theta_sq,cos_phi_sq,sin_phi_sq
+ double precision theta,phi,factor,gxl,gyl,gzl,sx_l,sy_l,sz_l
+ double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
+ double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: xstore,ystore,zstore
+
+! this for non blocking MPI
+ integer :: iphase,icall
+
+ integer :: computed_elements
+
+ logical, dimension(NSPEC_INNER_CORE) :: is_on_a_slice_edge_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+
+ integer :: ichunk,iproc_xi,iproc_eta,myrank
+
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+
+ 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
+
+ integer npoin2D_faces_crust_mantle(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_inner_core,npoin2D_eta_inner_core
+
+! 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(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
+
+ integer :: npoin2D_max_all_CM_IC
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
+
+! 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_chunkcorn_vector,buffer_recv_chunkcorn_vector
+
+! for matching with central cube in inner core
+ integer nb_msgs_theor_in_cube, npoin2D_cube_from_slices,iphase_CC
+ integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
+ double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices
+ double precision, dimension(npoin2D_cube_from_slices,NDIM,nb_msgs_theor_in_cube) :: buffer_all_cube_from_slices
+ integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
+ integer receiver_cube_from_slices
+ logical :: INCLUDE_CENTRAL_CUBE
+
+! local to global mapping
+ integer NSPEC2D_BOTTOM_INNER_CORE
+ integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
+
+! ****************************************************
+! big loop over all spectral elements in the solid
+! ****************************************************
+
+ computed_elements = 0
+
+ do ispec = 1,NSPEC_INNER_CORE
+
+! hide communications by computing the edges first
+ if((icall == 2 .and. is_on_a_slice_edge_inner_core(ispec)) .or. &
+ (icall == 1 .and. .not. is_on_a_slice_edge_inner_core(ispec))) cycle
+
+! exclude fictitious elements in central cube
+ if(idoubling(ispec) /= IFLAG_IN_FICTITIOUS_CUBE) then
+
+! process the communications every ELEMENTS_NONBLOCKING elements
+ computed_elements = computed_elements + 1
+ if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_CM_IC) == 0) then
+
+ if(iphase <= 7) call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_CM, &
+ NGLOB1D_RADIAL_IC,NCHUNKS_VAL,iphase)
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ if(iphase > 7 .and. iphase_CC <= 4) &
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,accel_inner_core,NDIM,iphase_CC)
+ endif
+
+ endif
+
+ 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_inner_core(1,iglob)*hp1
+ tempy1l = tempy1l + displ_inner_core(2,iglob)*hp1
+ tempz1l = tempz1l + displ_inner_core(3,iglob)*hp1
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(j,l)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + displ_inner_core(1,iglob)*hp2
+ tempy2l = tempy2l + displ_inner_core(2,iglob)*hp2
+ tempz2l = tempz2l + displ_inner_core(3,iglob)*hp2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(k,l)
+ iglob = ibool(i,j,l,ispec)
+ tempx3l = tempx3l + displ_inner_core(1,iglob)*hp3
+ tempy3l = tempy3l + displ_inner_core(2,iglob)*hp3
+ tempz3l = tempz3l + displ_inner_core(3,iglob)*hp3
+ enddo
+
+! get derivatives of ux, uy and uz with respect to x, y and z
+
+ 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
+ if(NSPEC_INNER_CORE_STRAIN_ONLY == 1) then
+ ispec_strain = 1
+ else
+ ispec_strain = ispec
+ endif
+ epsilon_trace_over_3(i,j,k,ispec_strain) = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(1,i,j,k) = duxdxl - epsilon_trace_over_3(i,j,k,ispec_strain)
+ epsilondev_loc(2,i,j,k) = duydyl - epsilon_trace_over_3(i,j,k,ispec_strain)
+ epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
+ endif
+
+ if(ATTENUATION_VAL) then
+ minus_sum_beta = one_minus_sum_beta(i,j,k,ispec) - 1.0
+ endif
+
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+
+! elastic tensor for hexagonal symmetry in reduced notation:
+!
+! c11 c12 c13 0 0 0
+! c12 c11 c13 0 0 0
+! c13 c13 c33 0 0 0
+! 0 0 0 c44 0 0
+! 0 0 0 0 c44 0
+! 0 0 0 0 0 (c11-c12)/2
+!
+! in terms of the A, C, L, N and F of Love (1927):
+!
+! c11 = A
+! c12 = A-2N
+! c13 = F
+! c33 = C
+! c44 = L
+
+ c11l = c11store(i,j,k,ispec)
+ c12l = c12store(i,j,k,ispec)
+ c13l = c13store(i,j,k,ispec)
+ c33l = c33store(i,j,k,ispec)
+ c44l = c44store(i,j,k,ispec)
+
+! use unrelaxed parameters if attenuation
+ if(ATTENUATION_VAL) then
+ mul = muvstore(i,j,k,ispec)
+ c11l = c11l + FOUR_THIRDS * minus_sum_beta * mul
+ c12l = c12l - TWO_THIRDS * minus_sum_beta * mul
+ c13l = c13l - TWO_THIRDS * minus_sum_beta * mul
+ c33l = c33l + FOUR_THIRDS * minus_sum_beta * mul
+ c44l = c44l + minus_sum_beta * mul
+ endif
+
+ sigma_xx = c11l*duxdxl + c12l*duydyl + c13l*duzdzl
+ sigma_yy = c12l*duxdxl + c11l*duydyl + c13l*duzdzl
+ sigma_zz = c13l*duxdxl + c13l*duydyl + c33l*duzdzl
+ sigma_xy = 0.5*(c11l-c12l)*duxdyl_plus_duydxl
+ sigma_xz = c44l*duzdxl_plus_duxdzl
+ sigma_yz = c44l*duzdyl_plus_duydzl
+ else
+
+! 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(i,j,k,ispec)
+ 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 .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) 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
+
+! define symmetric components of sigma for gravity
+ sigma_yx = sigma_xy
+ sigma_zx = sigma_xz
+ sigma_zy = sigma_yz
+
+! compute non-symmetric terms for gravity
+ if(GRAVITY_VAL) then
+
+! use mesh coordinates to get theta and phi
+! x y and z contain r theta and phi
+
+ iglob = ibool(i,j,k,ispec)
+ radius = dble(xstore(iglob))
+ theta = dble(ystore(iglob))
+ phi = dble(zstore(iglob))
+
+! make sure radius is never zero even for points at center of cube
+! because we later divide by radius
+ if(radius < 100.d0 / R_EARTH) radius = 100.d0 / R_EARTH
+
+ cos_theta = dcos(theta)
+ sin_theta = dsin(theta)
+ cos_phi = dcos(phi)
+ sin_phi = dsin(phi)
+
+! get g, rho and dg/dr=dg
+! spherical components of the gravitational acceleration
+! for efficiency replace with lookup table every 100 m in radial direction
+! make sure we never use zero for point exactly at the center of the Earth
+ int_radius = max(1,nint(radius * R_EARTH_KM * 10.d0))
+ minus_g = minus_gravity_table(int_radius)
+ minus_dg = minus_deriv_gravity_table(int_radius)
+ rho = density_table(int_radius)
+
+! Cartesian components of the gravitational acceleration
+ gxl = minus_g*sin_theta*cos_phi
+ gyl = minus_g*sin_theta*sin_phi
+ gzl = minus_g*cos_theta
+
+! Cartesian components of gradient of gravitational acceleration
+! obtained from spherical components
+
+ minus_g_over_radius = minus_g / radius
+ minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
+
+ cos_theta_sq = cos_theta**2
+ sin_theta_sq = sin_theta**2
+ cos_phi_sq = cos_phi**2
+ sin_phi_sq = sin_phi**2
+
+ Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
+ Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
+ Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
+ Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
+ Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
+ Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
+
+ iglob = ibool(i,j,k,ispec)
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+! get displacement and multiply by density to compute G tensor
+ sx_l = rho * dble(displ_inner_core(1,iglob))
+ sy_l = rho * dble(displ_inner_core(2,iglob))
+ sz_l = rho * dble(displ_inner_core(3,iglob))
+
+! compute G tensor from s . g and add to sigma (not symmetric)
+ sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
+ sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
+ sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
+
+ sigma_xy = sigma_xy - sngl(sx_l * gyl)
+ sigma_yx = sigma_yx - sngl(sy_l * gxl)
+
+ sigma_xz = sigma_xz - sngl(sx_l * gzl)
+ sigma_zx = sigma_zx - sngl(sz_l * gxl)
+
+ sigma_yz = sigma_yz - sngl(sy_l * gzl)
+ sigma_zy = sigma_zy - sngl(sz_l * gyl)
+
+! precompute vector
+ factor = dble(jacobianl) * wgll_cube(i,j,k)
+ rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
+ rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
+ rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
+
+ else
+
+! get displacement and multiply by density to compute G tensor
+ sx_l = rho * displ_inner_core(1,iglob)
+ sy_l = rho * displ_inner_core(2,iglob)
+ sz_l = rho * displ_inner_core(3,iglob)
+
+! compute G tensor from s . g and add to sigma (not symmetric)
+ sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
+ sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
+ sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
+
+ sigma_xy = sigma_xy - sx_l * gyl
+ sigma_yx = sigma_yx - sy_l * gxl
+
+ sigma_xz = sigma_xz - sx_l * gzl
+ sigma_zx = sigma_zx - sz_l * gxl
+
+ sigma_yz = sigma_yz - sy_l * gzl
+ sigma_zy = sigma_zy - sz_l * gyl
+
+! precompute vector
+ factor = jacobianl * wgll_cube(i,j,k)
+ rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
+ rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
+ rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
+
+ endif
+
+ endif ! end of section with gravity terms
+
+! form dot product with test vector, non-symmetric form
+
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ 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)
+
+ if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
+
+ enddo
+ enddo
+ enddo
+
+! sum contributions from each element to the global mesh and add gravity terms
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ accel_inner_core(:,iglob) = accel_inner_core(:,iglob) + sum_terms(:,i,j,k)
+ enddo
+ enddo
+ enddo
+
+! use Runge-Kutta scheme to march memory variables in time
+! convention for attenuation
+! term in xx = 1
+! term in yy = 2
+! term in xy = 3
+! term in xz = 4
+! term in yz = 5
+! term in zz not computed since zero trace
+! This is because we only implement Q_\mu attenuation and not Q_\kappa.
+! Note that this does *NOT* imply that there is no attenuation for P waves
+! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
+! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
+! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
+! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
+
+ if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. )) then
+
+ do i_SLS = 1,N_SLS
+ factor_common_use = factor_common(i_SLS,:,:,:,ispec)
+ do i_memory = 1,5
+ R_memory(i_memory,i_SLS,:,:,:,ispec) = &
+ alphaval(i_SLS) * &
+ R_memory(i_memory,i_SLS,:,:,:,ispec) + muvstore(:,:,:,ispec) * &
+ factor_common_use * &
+ (betaval(i_SLS) * &
+ epsilondev(i_memory,:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
+ enddo
+ enddo
+
+ endif
+
+ if (COMPUTE_AND_STORE_STRAIN) then
+! save deviatoric strain for Runge-Kutta scheme
+ !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ epsilondev(:,i,j,k,ispec) = epsilondev_loc(:,i,j,k)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ endif ! end test to exclude fictitious elements in central cube
+
+ enddo ! spectral element loop
+
+ end subroutine compute_forces_inner_core
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_inner_core_Dev.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core_Dev.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_inner_core_Dev.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_inner_core_Dev.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,885 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core,xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+!----------------------
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_INNER_CORE,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore,muvstore,ibool,idoubling, &
+ c11store,c33store,c12store,c13store,c44store,R_memory,epsilondev,epsilon_trace_over_3,&
+ one_minus_sum_beta,alphaval,betaval,gammaval,factor_common, &
+ vx,vy,vz,vnspec)
+
+! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
+
+ 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(NDIM,NGLOB_INNER_CORE) :: displ_inner_core,accel_inner_core
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: xstore,ystore,zstore
+
+ ! arrays with mesh parameters per slice
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: xix,xiy,xiz, &
+ etax,etay,etaz,gammax,gammay,gammaz
+
+ ! for attenuation
+ ! memory variables R_ij are stored at the local rather than global level
+ ! to allow for optimization of cache access by compiler
+ ! variable lengths for factor_common and one_minus_sum_beta
+ integer vx, vy, vz, vnspec
+ real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: factor_common
+ real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX, NGLLY, NGLLZ) :: factor_common_use
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilon_trace_over_3
+
+ ! array with derivatives of Lagrange polynomials and precalculated products
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
+ real(kind=CUSTOM_REAL), dimension(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,NSPEC_INNER_CORE) :: kappavstore,muvstore
+
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
+! c11store,c33store,c12store,c13store,c44store
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
+ c11store,c33store,c12store,c13store,c44store
+
+ ! array with the local to global mapping per slice
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling
+
+ double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
+
+! local parameters
+ ! Deville
+ ! manually inline the calls to the Deville et al. (2002) routines
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
+ newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: E1_m1_m2_5points,E2_m1_m2_5points,E3_m1_m2_5points
+
+ equivalence(dummyx_loc,B1_m1_m2_5points)
+ equivalence(dummyy_loc,B2_m1_m2_5points)
+ equivalence(dummyz_loc,B3_m1_m2_5points)
+ equivalence(tempx1,C1_m1_m2_5points)
+ equivalence(tempy1,C2_m1_m2_5points)
+ equivalence(tempz1,C3_m1_m2_5points)
+ equivalence(newtempx1,E1_m1_m2_5points)
+ equivalence(newtempy1,E2_m1_m2_5points)
+ equivalence(newtempz1,E3_m1_m2_5points)
+
+ real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: &
+ A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ E1_mxm_m2_m1_5points,E2_mxm_m2_m1_5points,E3_mxm_m2_m1_5points
+
+ equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
+ equivalence(dummyy_loc,A2_mxm_m2_m1_5points)
+ equivalence(dummyz_loc,A3_mxm_m2_m1_5points)
+ equivalence(tempx3,C1_mxm_m2_m1_5points)
+ equivalence(tempy3,C2_mxm_m2_m1_5points)
+ equivalence(tempz3,C3_mxm_m2_m1_5points)
+ equivalence(newtempx3,E1_mxm_m2_m1_5points)
+ equivalence(newtempy3,E2_mxm_m2_m1_5points)
+ equivalence(newtempz3,E3_mxm_m2_m1_5points)
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+ real(kind=CUSTOM_REAL) R_xx_val1,R_yy_val1,R_xx_val2,R_yy_val2,R_xx_val3,R_yy_val3
+
+ 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) fac1,fac2,fac3,templ
+ real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) kappal
+
+ real(kind=CUSTOM_REAL) minus_sum_beta
+ real(kind=CUSTOM_REAL) c11l,c33l,c12l,c13l,c44l
+
+ ! for gravity
+ double precision radius,rho,minus_g,minus_dg
+ double precision minus_g_over_radius,minus_dg_plus_g_over_radius
+ double precision cos_theta,sin_theta,cos_phi,sin_phi
+ double precision cos_theta_sq,sin_theta_sq,cos_phi_sq,sin_phi_sq
+ double precision theta,phi,factor,gxl,gyl,gzl,sx_l,sy_l,sz_l
+ double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
+ real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
+
+ integer :: int_radius
+ integer :: ispec,ispec_strain
+ integer :: i,j,k !,l
+ integer :: i_SLS,i_memory,imodulo_N_SLS
+ integer :: iglob1,iglob2,iglob3,iglob4,iglob5
+
+! this for non blocking MPI
+ integer :: iphase,icall
+
+ integer :: computed_elements
+
+ logical, dimension(NSPEC_INNER_CORE) :: is_on_a_slice_edge_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+
+ integer :: ichunk,iproc_xi,iproc_eta,myrank
+
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+
+ 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
+
+ integer npoin2D_faces_crust_mantle(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_inner_core,npoin2D_eta_inner_core
+
+! 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(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
+
+ integer :: npoin2D_max_all_CM_IC
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
+
+! 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_chunkcorn_vector,buffer_recv_chunkcorn_vector
+
+! for matching with central cube in inner core
+ integer nb_msgs_theor_in_cube, npoin2D_cube_from_slices,iphase_CC
+ integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
+ double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices
+ double precision, dimension(npoin2D_cube_from_slices,NDIM,nb_msgs_theor_in_cube) :: buffer_all_cube_from_slices
+ integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
+ integer receiver_cube_from_slices
+ logical :: INCLUDE_CENTRAL_CUBE
+
+! local to global mapping
+ integer NSPEC2D_BOTTOM_INNER_CORE
+ integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
+
+! ****************************************************
+! big loop over all spectral elements in the solid
+! ****************************************************
+
+ imodulo_N_SLS = mod(N_SLS,3)
+
+ computed_elements = 0
+
+ do ispec = 1,NSPEC_INNER_CORE
+
+! hide communications by computing the edges first
+ if((icall == 2 .and. is_on_a_slice_edge_inner_core(ispec)) .or. &
+ (icall == 1 .and. .not. is_on_a_slice_edge_inner_core(ispec))) cycle
+
+ ! exclude fictitious elements in central cube
+ if(idoubling(ispec) /= IFLAG_IN_FICTITIOUS_CUBE) then
+
+! process the communications every ELEMENTS_NONBLOCKING elements
+ computed_elements = computed_elements + 1
+ if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_CM_IC) == 0) then
+
+ if(iphase <= 7) call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_CM, &
+ NGLOB1D_RADIAL_IC,NCHUNKS_VAL,iphase)
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ if(iphase > 7 .and. iphase_CC <= 4) &
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,accel_inner_core,NDIM,iphase_CC)
+ endif
+
+ endif
+
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! for incompressible fluid flow, Cambridge University Press (2002),
+ ! pages 386 and 389 and Figure 8.3.1
+ do k=1,NGLLZ
+ do j=1,NGLLY
+! way 1:
+! do i=1,NGLLX
+! iglob = ibool(i,j,k,ispec)
+! dummyx_loc(i,j,k) = displ_inner_core(1,iglob)
+! dummyy_loc(i,j,k) = displ_inner_core(2,iglob)
+! dummyz_loc(i,j,k) = displ_inner_core(3,iglob)
+! enddo
+
+! way 2:
+ ! since we know that NGLLX = 5, this should help pipelining
+ iglob1 = ibool(1,j,k,ispec)
+ iglob2 = ibool(2,j,k,ispec)
+ iglob3 = ibool(3,j,k,ispec)
+ iglob4 = ibool(4,j,k,ispec)
+ iglob5 = ibool(5,j,k,ispec)
+
+ dummyx_loc(1,j,k) = displ_inner_core(1,iglob1)
+ dummyy_loc(1,j,k) = displ_inner_core(2,iglob1)
+ dummyz_loc(1,j,k) = displ_inner_core(3,iglob1)
+
+ dummyx_loc(2,j,k) = displ_inner_core(1,iglob2)
+ dummyy_loc(2,j,k) = displ_inner_core(2,iglob2)
+ dummyz_loc(2,j,k) = displ_inner_core(3,iglob2)
+
+ dummyx_loc(3,j,k) = displ_inner_core(1,iglob3)
+ dummyy_loc(3,j,k) = displ_inner_core(2,iglob3)
+ dummyz_loc(3,j,k) = displ_inner_core(3,iglob3)
+
+ dummyx_loc(4,j,k) = displ_inner_core(1,iglob4)
+ dummyy_loc(4,j,k) = displ_inner_core(2,iglob4)
+ dummyz_loc(4,j,k) = displ_inner_core(3,iglob4)
+
+ dummyx_loc(5,j,k) = displ_inner_core(1,iglob5)
+ dummyy_loc(5,j,k) = displ_inner_core(2,iglob5)
+ dummyz_loc(5,j,k) = displ_inner_core(3,iglob5)
+
+
+ enddo
+ enddo
+ do j=1,m2
+ do i=1,m1
+ C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B1_m1_m2_5points(5,j)
+
+ C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B2_m1_m2_5points(5,j)
+
+ C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B3_m1_m2_5points(5,j)
+ enddo
+ enddo
+ do j=1,m1
+ do i=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyx_loc(i,5,k)*hprime_xxT(5,j)
+
+ tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyy_loc(i,5,k)*hprime_xxT(5,j)
+
+ tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ enddo
+ enddo
+ enddo
+ do j=1,m1
+ do i=1,m2
+ C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+
+ C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+
+ C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+ ! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ duxdxl = xixl*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
+ duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
+ duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
+
+ duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
+ duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
+ duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
+
+ duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
+ duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
+ duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
+
+ ! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
+
+ ! compute deviatoric strain
+ if (COMPUTE_AND_STORE_STRAIN) then
+ if(NSPEC_INNER_CORE_STRAIN_ONLY == 1) then
+ ispec_strain = 1
+ else
+ ispec_strain = ispec
+ endif
+ templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilon_trace_over_3(i,j,k,ispec_strain) = templ
+ epsilondev_loc(1,i,j,k) = duxdxl - templ
+ epsilondev_loc(2,i,j,k) = duydyl - templ
+ epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
+ 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
+ minus_sum_beta = one_minus_sum_beta(i,j,k,ispec) - 1.0
+ endif
+
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+ ! elastic tensor for hexagonal symmetry in reduced notation:
+ !
+ ! c11 c12 c13 0 0 0
+ ! c12 c11 c13 0 0 0
+ ! c13 c13 c33 0 0 0
+ ! 0 0 0 c44 0 0
+ ! 0 0 0 0 c44 0
+ ! 0 0 0 0 0 (c11-c12)/2
+ !
+ ! in terms of the A, C, L, N and F of Love (1927):
+ !
+ ! c11 = A
+ ! c12 = A-2N
+ ! c13 = F
+ ! c33 = C
+ ! c44 = L
+ c11l = c11store(i,j,k,ispec)
+ c12l = c12store(i,j,k,ispec)
+ c13l = c13store(i,j,k,ispec)
+ c33l = c33store(i,j,k,ispec)
+ c44l = c44store(i,j,k,ispec)
+
+ ! use unrelaxed parameters if attenuation
+ if(ATTENUATION_VAL) then
+ mul = muvstore(i,j,k,ispec)
+ c11l = c11l + FOUR_THIRDS * minus_sum_beta * mul
+ c12l = c12l - TWO_THIRDS * minus_sum_beta * mul
+ c13l = c13l - TWO_THIRDS * minus_sum_beta * mul
+ c33l = c33l + FOUR_THIRDS * minus_sum_beta * mul
+ c44l = c44l + minus_sum_beta * mul
+ endif
+
+ sigma_xx = c11l*duxdxl + c12l*duydyl + c13l*duzdzl
+ sigma_yy = c12l*duxdxl + c11l*duydyl + c13l*duzdzl
+ sigma_zz = c13l*duxdxl + c13l*duydyl + c33l*duzdzl
+ sigma_xy = 0.5*(c11l-c12l)*duxdyl_plus_duydxl
+ sigma_xz = c44l*duzdxl_plus_duxdzl
+ sigma_yz = c44l*duzdyl_plus_duydzl
+ else
+
+ ! 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(i,j,k,ispec)
+ 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 .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) then
+
+! way 1:
+! 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
+
+! way 2:
+! note: this should help compilers to pipeline the code and make better use of the cache;
+! depending on compilers, it can further decrease the computation time by ~ 30%.
+! by default, N_SLS = 3, there for we take steps of 3
+ if(imodulo_N_SLS >= 1) then
+ do i_SLS = 1,imodulo_N_SLS
+ R_xx_val1 = R_memory(1,i_SLS,i,j,k,ispec)
+ R_yy_val1 = R_memory(2,i_SLS,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val1
+ sigma_yy = sigma_yy - R_yy_val1
+ sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
+ sigma_xy = sigma_xy - R_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
+
+ if(N_SLS >= imodulo_N_SLS+1) then
+ do i_SLS = imodulo_N_SLS+1,N_SLS,3
+ R_xx_val1 = R_memory(1,i_SLS,i,j,k,ispec)
+ R_yy_val1 = R_memory(2,i_SLS,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val1
+ sigma_yy = sigma_yy - R_yy_val1
+ sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
+ sigma_xy = sigma_xy - R_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)
+
+ R_xx_val2 = R_memory(1,i_SLS+1,i,j,k,ispec)
+ R_yy_val2 = R_memory(2,i_SLS+1,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val2
+ sigma_yy = sigma_yy - R_yy_val2
+ sigma_zz = sigma_zz + R_xx_val2 + R_yy_val2
+ sigma_xy = sigma_xy - R_memory(3,i_SLS+1,i,j,k,ispec)
+ sigma_xz = sigma_xz - R_memory(4,i_SLS+1,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_memory(5,i_SLS+1,i,j,k,ispec)
+
+ R_xx_val3 = R_memory(1,i_SLS+2,i,j,k,ispec)
+ R_yy_val3 = R_memory(2,i_SLS+2,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val3
+ sigma_yy = sigma_yy - R_yy_val3
+ sigma_zz = sigma_zz + R_xx_val3 + R_yy_val3
+ sigma_xy = sigma_xy - R_memory(3,i_SLS+2,i,j,k,ispec)
+ sigma_xz = sigma_xz - R_memory(4,i_SLS+2,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_memory(5,i_SLS+2,i,j,k,ispec)
+ enddo
+ endif
+
+ endif
+
+ ! define symmetric components of sigma for gravity
+ sigma_yx = sigma_xy
+ sigma_zx = sigma_xz
+ sigma_zy = sigma_yz
+
+ ! compute non-symmetric terms for gravity
+ if(GRAVITY_VAL) then
+
+ ! use mesh coordinates to get theta and phi
+ ! x y and z contain r theta and phi
+ iglob1 = ibool(i,j,k,ispec)
+ radius = dble(xstore(iglob1))
+ theta = dble(ystore(iglob1))
+ phi = dble(zstore(iglob1))
+
+ ! make sure radius is never zero even for points at center of cube
+ ! because we later divide by radius
+ if(radius < 100.d0 / R_EARTH) radius = 100.d0 / R_EARTH
+
+ cos_theta = dcos(theta)
+ sin_theta = dsin(theta)
+ cos_phi = dcos(phi)
+ sin_phi = dsin(phi)
+
+ cos_theta_sq = cos_theta**2
+ sin_theta_sq = sin_theta**2
+ cos_phi_sq = cos_phi**2
+ sin_phi_sq = sin_phi**2
+
+ ! get g, rho and dg/dr=dg
+ ! spherical components of the gravitational acceleration
+ ! for efficiency replace with lookup table every 100 m in radial direction
+ ! make sure we never use zero for point exactly at the center of the Earth
+ int_radius = max(1,nint(radius * R_EARTH_KM * 10.d0))
+ minus_g = minus_gravity_table(int_radius)
+ minus_dg = minus_deriv_gravity_table(int_radius)
+ rho = density_table(int_radius)
+
+ ! Cartesian components of the gravitational acceleration
+ gxl = minus_g*sin_theta*cos_phi
+ gyl = minus_g*sin_theta*sin_phi
+ gzl = minus_g*cos_theta
+
+ ! Cartesian components of gradient of gravitational acceleration
+ ! obtained from spherical components
+ minus_g_over_radius = minus_g / radius
+ minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
+
+ Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
+ Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
+ Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
+ Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
+ Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
+ Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
+
+ ! for locality principle, we set iglob again, in order to have it in the cache again
+ iglob1 = ibool(i,j,k,ispec)
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ ! get displacement and multiply by density to compute G tensor
+ sx_l = rho * dble(displ_inner_core(1,iglob1))
+ sy_l = rho * dble(displ_inner_core(2,iglob1))
+ sz_l = rho * dble(displ_inner_core(3,iglob1))
+
+ ! compute G tensor from s . g and add to sigma (not symmetric)
+ sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
+ sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
+ sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
+
+ sigma_xy = sigma_xy - sngl(sx_l * gyl)
+ sigma_yx = sigma_yx - sngl(sy_l * gxl)
+
+ sigma_xz = sigma_xz - sngl(sx_l * gzl)
+ sigma_zx = sigma_zx - sngl(sz_l * gxl)
+
+ sigma_yz = sigma_yz - sngl(sy_l * gzl)
+ sigma_zy = sigma_zy - sngl(sz_l * gyl)
+
+ ! precompute vector
+ factor = dble(jacobianl) * wgll_cube(i,j,k)
+ rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
+ rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
+ rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
+
+ else
+
+ ! get displacement and multiply by density to compute G tensor
+ sx_l = rho * displ_inner_core(1,iglob1)
+ sy_l = rho * displ_inner_core(2,iglob1)
+ sz_l = rho * displ_inner_core(3,iglob1)
+
+ ! compute G tensor from s . g and add to sigma (not symmetric)
+ sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
+ sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
+ sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
+
+ sigma_xy = sigma_xy - sx_l * gyl
+ sigma_yx = sigma_yx - sy_l * gxl
+
+ sigma_xz = sigma_xz - sx_l * gzl
+ sigma_zx = sigma_zx - sz_l * gxl
+
+ sigma_yz = sigma_yz - sy_l * gzl
+ sigma_zy = sigma_zy - sz_l * gyl
+
+ ! precompute vector
+ factor = jacobianl * wgll_cube(i,j,k)
+ rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
+ rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
+ rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
+
+ endif
+
+ endif ! end of section with gravity terms
+
+ ! form dot product with test vector, non-symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! for incompressible fluid flow, Cambridge University Press (2002),
+ ! pages 386 and 389 and Figure 8.3.1
+ do j=1,m2
+ do i=1,m1
+ E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
+
+ E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
+
+ E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
+ enddo
+ enddo
+ do i=1,m1
+ do j=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempx2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempx2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempx2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempx2(i,5,k)*hprimewgll_xx(5,j)
+
+ newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempy2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempy2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempy2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempy2(i,5,k)*hprimewgll_xx(5,j)
+
+ newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempz2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempz2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempz2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempz2(i,5,k)*hprimewgll_xx(5,j)
+ enddo
+ enddo
+ enddo
+ do j=1,m1
+ do i=1,m2
+ E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+
+ E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+
+ E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+
+ ! sum contributions
+ sum_terms(1,i,j,k) = - (fac1*newtempx1(i,j,k) + fac2*newtempx2(i,j,k) + fac3*newtempx3(i,j,k))
+ sum_terms(2,i,j,k) = - (fac1*newtempy1(i,j,k) + fac2*newtempy2(i,j,k) + fac3*newtempy3(i,j,k))
+ sum_terms(3,i,j,k) = - (fac1*newtempz1(i,j,k) + fac2*newtempz2(i,j,k) + fac3*newtempz3(i,j,k))
+
+ if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
+
+ enddo
+ enddo
+ enddo
+
+ ! sum contributions from each element to the global mesh and add gravity terms
+ do k=1,NGLLZ
+ do j=1,NGLLY
+! way 1:
+! do i=1,NGLLX
+! iglob = ibool(i,j,k,ispec)
+! accel_inner_core(:,iglob) = accel_inner_core(:,iglob) + sum_terms(:,i,j,k)
+! enddo
+
+! way 2:
+ accel_inner_core(:,ibool(1,j,k,ispec)) = accel_inner_core(:,ibool(1,j,k,ispec)) + sum_terms(:,1,j,k)
+ accel_inner_core(:,ibool(2,j,k,ispec)) = accel_inner_core(:,ibool(2,j,k,ispec)) + sum_terms(:,2,j,k)
+ accel_inner_core(:,ibool(3,j,k,ispec)) = accel_inner_core(:,ibool(3,j,k,ispec)) + sum_terms(:,3,j,k)
+ accel_inner_core(:,ibool(4,j,k,ispec)) = accel_inner_core(:,ibool(4,j,k,ispec)) + sum_terms(:,4,j,k)
+ accel_inner_core(:,ibool(5,j,k,ispec)) = accel_inner_core(:,ibool(5,j,k,ispec)) + sum_terms(:,5,j,k)
+
+ enddo
+ enddo
+
+ ! use Runge-Kutta scheme to march memory variables in time
+ ! convention for attenuation
+ ! term in xx = 1
+ ! term in yy = 2
+ ! term in xy = 3
+ ! term in xz = 4
+ ! term in yz = 5
+ ! term in zz not computed since zero trace
+ ! This is because we only implement Q_\mu attenuation and not Q_\kappa.
+ ! Note that this does *NOT* imply that there is no attenuation for P waves
+ ! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
+ ! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
+ ! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
+ ! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
+ if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) then
+ do i_SLS = 1,N_SLS
+ factor_common_use = factor_common(i_SLS,:,:,:,ispec)
+ do i_memory = 1,5
+ R_memory(i_memory,i_SLS,:,:,:,ispec) = &
+ alphaval(i_SLS) * &
+ R_memory(i_memory,i_SLS,:,:,:,ispec) + muvstore(:,:,:,ispec) * &
+ factor_common_use * &
+ (betaval(i_SLS) * &
+ epsilondev(i_memory,:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
+ enddo
+ enddo
+
+ endif
+
+ ! save deviatoric strain for Runge-Kutta scheme
+ if(COMPUTE_AND_STORE_STRAIN) then
+! way 1:
+ !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
+! way 2:
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ !dummy(:) = epsilondev_loc(:,1,j,k)
+
+ epsilondev(:,1,j,k,ispec) = epsilondev_loc(:,1,j,k)
+ epsilondev(:,2,j,k,ispec) = epsilondev_loc(:,2,j,k)
+ epsilondev(:,3,j,k,ispec) = epsilondev_loc(:,3,j,k)
+ epsilondev(:,4,j,k,ispec) = epsilondev_loc(:,4,j,k)
+ epsilondev(:,5,j,k,ispec) = epsilondev_loc(:,5,j,k)
+ enddo
+ enddo
+ endif
+
+ endif ! end test to exclude fictitious elements in central cube
+
+ enddo ! spectral element loop
+
+ end subroutine compute_forces_inner_core_Dev
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_outer_core.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_outer_core.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_outer_core.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,397 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation, &
+ d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displfluid,accelfluid, &
+ div_displfluid, &
+ xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool,MOVIE_VOLUME)
+
+ 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
+
+! divergence of displacement
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: div_displfluid
+
+! 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
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+ logical MOVIE_VOLUME
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: tempx1,tempx2,tempx3
+
+! for gravity
+ integer int_radius
+ double precision radius,theta,phi,gxl,gyl,gzl
+ double precision cos_theta,sin_theta,cos_phi,sin_phi
+ double precision, dimension(NRAD_GRAVITY) :: minus_rho_g_over_kappa_fluid
+ double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: gravity_term
+ real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: xstore,ystore,zstore
+
+! for the Euler scheme for rotation
+ real(kind=CUSTOM_REAL) time,deltat,two_omega_earth
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
+ A_array_rotation,B_array_rotation
+
+ real(kind=CUSTOM_REAL) two_omega_deltat,cos_two_omega_t,sin_two_omega_t,A_rotation,B_rotation, &
+ ux_rotation,uy_rotation,dpotentialdx_with_rot,dpotentialdy_with_rot
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: source_euler_A,source_euler_B
+
+ integer ispec,iglob
+ 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,sum_terms
+
+ double precision grad_x_ln_rho,grad_y_ln_rho,grad_z_ln_rho
+
+! this for non blocking MPI
+ integer :: ichunk,iproc_xi,iproc_eta,myrank
+
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+
+ 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 npoin2D_faces_outer_core(NUMFACES_SHARED)
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
+
+! 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
+
+! 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,NUMFACES_SHARED) :: iboolfaces_outer_core
+
+! buffers for send and receive between faces of the slices and the chunks
+! we use the same buffers to assemble scalars and vectors because vectors are
+! always three times bigger and therefore scalars can use the first part
+! of the vector buffer in memory even if it has an additional index here
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+ integer :: npoin2D_max_all_CM_IC
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED) :: buffer_send_faces,buffer_received_faces
+
+ integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL_OC) :: buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar
+
+ logical, dimension(NSPEC_OUTER_CORE) :: is_on_a_slice_edge_outer_core
+
+ integer :: iphase,icall
+
+ integer :: computed_elements
+
+! ****************************************************
+! big loop over all spectral elements in the fluid
+! ****************************************************
+
+ if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. icall == 1) div_displfluid(:,:,:,:) = 0._CUSTOM_REAL
+
+ computed_elements = 0
+
+ do ispec = 1,NSPEC_OUTER_CORE
+
+! hide communications by computing the edges first
+ if((icall == 2 .and. is_on_a_slice_edge_outer_core(ispec)) .or. &
+ (icall == 1 .and. .not. is_on_a_slice_edge_outer_core(ispec))) cycle
+
+! process the communications every ELEMENTS_NONBLOCKING elements
+ computed_elements = computed_elements + 1
+ if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_OC) == 0 .and. iphase <= 7) &
+ call assemble_MPI_scalar(myrank,accelfluid,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_OC, &
+ NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC,NGLOB2DMAX_XY_VAL,NCHUNKS_VAL,iphase)
+
+ 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
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ tempx1l = tempx1l + displfluid(ibool(l,j,k,ispec)) * hprime_xx(i,l)
+ tempx2l = tempx2l + displfluid(ibool(i,l,k,ispec)) * hprime_yy(j,l)
+ 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
+
+ ! compute contribution of rotation and add to gradient of potential
+ ! this term has no Z component
+ if(ROTATION_VAL) then
+
+ ! store the source for the Euler scheme for A_rotation and B_rotation
+ two_omega_deltat = deltat * two_omega_earth
+
+ cos_two_omega_t = cos(two_omega_earth*time)
+ sin_two_omega_t = sin(two_omega_earth*time)
+
+ ! time step deltat of Euler scheme is included in the source
+ source_euler_A(i,j,k) = two_omega_deltat * (cos_two_omega_t * dpotentialdyl + sin_two_omega_t * dpotentialdxl)
+ source_euler_B(i,j,k) = two_omega_deltat * (sin_two_omega_t * dpotentialdyl - cos_two_omega_t * dpotentialdxl)
+
+ A_rotation = A_array_rotation(i,j,k,ispec)
+ B_rotation = B_array_rotation(i,j,k,ispec)
+
+ ux_rotation = A_rotation*cos_two_omega_t + B_rotation*sin_two_omega_t
+ uy_rotation = - A_rotation*sin_two_omega_t + B_rotation*cos_two_omega_t
+
+ dpotentialdx_with_rot = dpotentialdxl + ux_rotation
+ dpotentialdy_with_rot = dpotentialdyl + uy_rotation
+
+ else
+
+ dpotentialdx_with_rot = dpotentialdxl
+ dpotentialdy_with_rot = dpotentialdyl
+
+ endif ! end of section with rotation
+
+ ! add (chi/rho)grad(rho) term in no gravity case
+ if(.not. GRAVITY_VAL) then
+ ! 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
+ iglob = ibool(i,j,k,ispec)
+
+ 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)
+ dpotentialdx_with_rot = dpotentialdx_with_rot + displfluid(iglob) * grad_x_ln_rho
+ dpotentialdy_with_rot = dpotentialdy_with_rot + displfluid(iglob) * grad_y_ln_rho
+ dpotentialdzl = dpotentialdzl + displfluid(iglob) * grad_z_ln_rho
+
+
+ else ! if gravity is turned on
+
+ ! compute divergence of displacment
+ ! precompute and store gravity term
+
+ ! use mesh coordinates to get theta and phi
+ ! x y z contain r theta phi
+ iglob = ibool(i,j,k,ispec)
+
+ 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)
+
+ ! get g, rho and dg/dr=dg
+ ! spherical components of the gravitational acceleration
+ ! for efficiency replace with lookup table every 100 m in radial direction
+ int_radius = nint(radius * R_EARTH_KM * 10.d0)
+
+ ! Cartesian components of the gravitational acceleration
+ ! integrate and multiply by rho / Kappa
+ gxl = sin_theta*cos_phi
+ gyl = sin_theta*sin_phi
+ gzl = cos_theta
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ gravity_term(i,j,k) = &
+ sngl(minus_rho_g_over_kappa_fluid(int_radius) * &
+ dble(jacobianl) * wgll_cube(i,j,k) * &
+ (dble(dpotentialdx_with_rot) * gxl + &
+ dble(dpotentialdy_with_rot) * gyl + dble(dpotentialdzl) * gzl))
+ else
+ gravity_term(i,j,k) = minus_rho_g_over_kappa_fluid(int_radius) * &
+ jacobianl * wgll_cube(i,j,k) * (dpotentialdx_with_rot * gxl + &
+ dpotentialdy_with_rot * gyl + dpotentialdzl * gzl)
+ endif
+
+ ! divergence of displacement field with gravity on
+ ! note: these calculations are only considered for SIMULATION_TYPE == 1 .and. SAVE_FORWARD
+ ! and one has set MOVIE_VOLUME_TYPE == 4 when MOVIE_VOLUME is .true.;
+ ! in case of SIMULATION_TYPE == 3, it gets overwritten by compute_kernels_outer_core()
+ if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. MOVIE_VOLUME ) then
+ div_displfluid(i,j,k,ispec) = &
+ minus_rho_g_over_kappa_fluid(int_radius) * (dpotentialdx_with_rot * gxl + &
+ dpotentialdy_with_rot * gyl + dpotentialdzl * gzl)
+ endif
+
+ endif
+
+ tempx1(i,j,k) = jacobianl*(xixl*dpotentialdx_with_rot + xiyl*dpotentialdy_with_rot + xizl*dpotentialdzl)
+ tempx2(i,j,k) = jacobianl*(etaxl*dpotentialdx_with_rot + etayl*dpotentialdy_with_rot + etazl*dpotentialdzl)
+ tempx3(i,j,k) = jacobianl*(gammaxl*dpotentialdx_with_rot + gammayl*dpotentialdy_with_rot + 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
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ tempx1l = tempx1l + tempx1(l,j,k) * hprimewgll_xx(l,i)
+ tempx2l = tempx2l + tempx2(i,l,k) * hprimewgll_yy(l,j)
+ tempx3l = tempx3l + tempx3(i,j,l) * hprimewgll_zz(l,k)
+ enddo
+
+ ! sum contributions from each element to the global mesh and add gravity term
+ sum_terms = - (wgllwgll_yz(j,k)*tempx1l + wgllwgll_xz(i,k)*tempx2l + wgllwgll_xy(i,j)*tempx3l)
+ if(GRAVITY_VAL) sum_terms = sum_terms + gravity_term(i,j,k)
+
+ accelfluid(ibool(i,j,k,ispec)) = accelfluid(ibool(i,j,k,ispec)) + sum_terms
+
+ enddo
+ enddo
+ enddo
+
+ ! update rotation term with Euler scheme
+ if(ROTATION_VAL) then
+ ! use the source saved above
+ A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + source_euler_A(:,:,:)
+ B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + source_euler_B(:,:,:)
+ endif
+
+ enddo ! spectral element loop
+
+ end subroutine compute_forces_outer_core
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_outer_core_Dev.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core_Dev.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_outer_core_Dev.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_forces_outer_core_Dev.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,481 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation, &
+ d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displfluid,accelfluid, &
+ div_displfluid, &
+ xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool,MOVIE_VOLUME)
+
+! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
+
+ 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
+
+! divergence of displacement
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: div_displfluid
+
+! 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(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
+ 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
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+ logical MOVIE_VOLUME
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: tempx1,tempx2,tempx3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: newtempx1,newtempx2,newtempx3
+
+! for gravity
+ integer int_radius
+ double precision radius,theta,phi,gxl,gyl,gzl
+ double precision cos_theta,sin_theta,cos_phi,sin_phi
+ double precision, dimension(NRAD_GRAVITY) :: minus_rho_g_over_kappa_fluid
+ double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: gravity_term
+ real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: xstore,ystore,zstore
+
+! for the Euler scheme for rotation
+ real(kind=CUSTOM_REAL) time,deltat,two_omega_earth
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
+ A_array_rotation,B_array_rotation
+
+ real(kind=CUSTOM_REAL) two_omega_deltat,cos_two_omega_t,sin_two_omega_t,A_rotation,B_rotation, &
+ ux_rotation,uy_rotation,dpotentialdx_with_rot,dpotentialdy_with_rot
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: source_euler_A,source_euler_B
+
+ integer ispec,iglob
+ integer i,j,k
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) sum_terms
+
+ ! manually inline the calls to the Deville et al. (2002) routines
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: E1_m1_m2_5points
+
+ equivalence(dummyx_loc,B1_m1_m2_5points)
+ equivalence(tempx1,C1_m1_m2_5points)
+ equivalence(newtempx1,E1_m1_m2_5points)
+
+ real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: A1_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: C1_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: E1_mxm_m2_m1_5points
+
+ equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
+ equivalence(tempx3,C1_mxm_m2_m1_5points)
+ equivalence(newtempx3,E1_mxm_m2_m1_5points)
+
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: temp_gxl,temp_gyl,temp_gzl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ displ_times_grad_x_ln_rho,displ_times_grad_y_ln_rho,displ_times_grad_z_ln_rho
+
+! this for non blocking MPI
+ integer :: ichunk,iproc_xi,iproc_eta,myrank
+
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+
+ 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 npoin2D_faces_outer_core(NUMFACES_SHARED)
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
+
+! 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
+
+! 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,NUMFACES_SHARED) :: iboolfaces_outer_core
+
+! buffers for send and receive between faces of the slices and the chunks
+! we use the same buffers to assemble scalars and vectors because vectors are
+! always three times bigger and therefore scalars can use the first part
+! of the vector buffer in memory even if it has an additional index here
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+ integer :: npoin2D_max_all_CM_IC
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED) :: buffer_send_faces,buffer_received_faces
+
+ integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL_OC) :: buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar
+
+ logical, dimension(NSPEC_OUTER_CORE) :: is_on_a_slice_edge_outer_core
+
+ integer :: iphase,icall
+
+ integer :: computed_elements
+
+! ****************************************************
+! big loop over all spectral elements in the fluid
+! ****************************************************
+
+ if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. icall == 1) div_displfluid(:,:,:,:) = 0._CUSTOM_REAL
+
+ computed_elements = 0
+
+ do ispec = 1,NSPEC_OUTER_CORE
+
+! hide communications by computing the edges first
+ if((icall == 2 .and. is_on_a_slice_edge_outer_core(ispec)) .or. &
+ (icall == 1 .and. .not. is_on_a_slice_edge_outer_core(ispec))) cycle
+
+! process the communications every ELEMENTS_NONBLOCKING elements
+ computed_elements = computed_elements + 1
+ if (USE_NONBLOCKING_COMMS .and. icall == 2 .and. mod(computed_elements,ELEMENTS_NONBLOCKING_OC) == 0 .and. iphase <= 7) &
+ call assemble_MPI_scalar(myrank,accelfluid,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_OC, &
+ NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC,NGLOB2DMAX_XY_VAL,NCHUNKS_VAL,iphase)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! stores "displacement"
+ dummyx_loc(i,j,k) = displfluid(iglob)
+
+ ! pre-computes factors
+ ! 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)
+
+ if( .not. GRAVITY_VAL ) then
+ ! grad(rho)/rho in Cartesian components
+ displ_times_grad_x_ln_rho(i,j,k) = dummyx_loc(i,j,k) &
+ * sngl(sin_theta * cos_phi * d_ln_density_dr_table(int_radius))
+ displ_times_grad_y_ln_rho(i,j,k) = dummyx_loc(i,j,k) &
+ * sngl(sin_theta * sin_phi * d_ln_density_dr_table(int_radius))
+ displ_times_grad_z_ln_rho(i,j,k) = dummyx_loc(i,j,k) &
+ * sngl(cos_theta * d_ln_density_dr_table(int_radius))
+ else
+ ! Cartesian components of the gravitational acceleration
+ ! integrate and multiply by rho / Kappa
+ temp_gxl(i,j,k) = sin_theta*cos_phi
+ temp_gyl(i,j,k) = sin_theta*sin_phi
+ temp_gzl(i,j,k) = cos_theta
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! for incompressible fluid flow, Cambridge University Press (2002),
+ ! pages 386 and 389 and Figure 8.3.1
+ do j=1,m2
+ do i=1,m1
+ C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B1_m1_m2_5points(5,j)
+ enddo
+ enddo
+ do k = 1,NGLLX
+ do j=1,m1
+ do i=1,m1
+ tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyx_loc(i,5,k)*hprime_xxT(5,j)
+ enddo
+ enddo
+ enddo
+ do j=1,m1
+ do i=1,m2
+ C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ enddo
+ enddo
+
+
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! 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*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
+ dpotentialdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
+ dpotentialdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
+
+ ! compute contribution of rotation and add to gradient of potential
+ ! this term has no Z component
+ if(ROTATION_VAL) then
+
+ ! store the source for the Euler scheme for A_rotation and B_rotation
+ two_omega_deltat = deltat * two_omega_earth
+
+ cos_two_omega_t = cos(two_omega_earth*time)
+ sin_two_omega_t = sin(two_omega_earth*time)
+
+ ! time step deltat of Euler scheme is included in the source
+ source_euler_A(i,j,k) = two_omega_deltat &
+ * (cos_two_omega_t * dpotentialdyl + sin_two_omega_t * dpotentialdxl)
+ source_euler_B(i,j,k) = two_omega_deltat &
+ * (sin_two_omega_t * dpotentialdyl - cos_two_omega_t * dpotentialdxl)
+
+ A_rotation = A_array_rotation(i,j,k,ispec)
+ B_rotation = B_array_rotation(i,j,k,ispec)
+
+ ux_rotation = A_rotation*cos_two_omega_t + B_rotation*sin_two_omega_t
+ uy_rotation = - A_rotation*sin_two_omega_t + B_rotation*cos_two_omega_t
+
+ dpotentialdx_with_rot = dpotentialdxl + ux_rotation
+ dpotentialdy_with_rot = dpotentialdyl + uy_rotation
+
+ else
+
+ dpotentialdx_with_rot = dpotentialdxl
+ dpotentialdy_with_rot = dpotentialdyl
+
+ endif ! end of section with rotation
+
+ ! add (chi/rho)grad(rho) term in no gravity case
+ if(.not. GRAVITY_VAL) then
+
+ ! 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
+ dpotentialdx_with_rot = dpotentialdx_with_rot + displ_times_grad_x_ln_rho(i,j,k)
+ dpotentialdy_with_rot = dpotentialdy_with_rot + displ_times_grad_y_ln_rho(i,j,k)
+ dpotentialdzl = dpotentialdzl + displ_times_grad_z_ln_rho(i,j,k)
+
+ else ! if gravity is turned on
+
+ ! compute divergence of displacment
+ gxl = temp_gxl(i,j,k)
+ gyl = temp_gyl(i,j,k)
+ gzl = temp_gzl(i,j,k)
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ gravity_term(i,j,k) = &
+ sngl( minus_rho_g_over_kappa_fluid(int_radius) &
+ * dble(jacobianl) * wgll_cube(i,j,k) &
+ * (dble(dpotentialdx_with_rot) * gxl &
+ + dble(dpotentialdy_with_rot) * gyl &
+ + dble(dpotentialdzl) * gzl) )
+ else
+ gravity_term(i,j,k) = minus_rho_g_over_kappa_fluid(int_radius) * &
+ jacobianl * wgll_cube(i,j,k) &
+ * (dpotentialdx_with_rot * gxl &
+ + dpotentialdy_with_rot * gyl &
+ + dpotentialdzl * gzl)
+ endif
+
+ ! divergence of displacement field with gravity on
+ ! note: these calculations are only considered for SIMULATION_TYPE == 1 .and. SAVE_FORWARD
+ ! and one has set MOVIE_VOLUME_TYPE == 4 when MOVIE_VOLUME is .true.;
+ ! in case of SIMULATION_TYPE == 3, it gets overwritten by compute_kernels_outer_core()
+ if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. MOVIE_VOLUME) then
+ div_displfluid(i,j,k,ispec) = &
+ minus_rho_g_over_kappa_fluid(int_radius) &
+ * (dpotentialdx_with_rot * gxl &
+ + dpotentialdy_with_rot * gyl &
+ + dpotentialdzl * gzl)
+ endif
+
+ endif
+
+ tempx1(i,j,k) = jacobianl*(xixl*dpotentialdx_with_rot &
+ + xiyl*dpotentialdy_with_rot + xizl*dpotentialdzl)
+ tempx2(i,j,k) = jacobianl*(etaxl*dpotentialdx_with_rot &
+ + etayl*dpotentialdy_with_rot + etazl*dpotentialdzl)
+ tempx3(i,j,k) = jacobianl*(gammaxl*dpotentialdx_with_rot &
+ + gammayl*dpotentialdy_with_rot + gammazl*dpotentialdzl)
+
+ enddo
+ enddo
+ enddo
+
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! for incompressible fluid flow, Cambridge University Press (2002),
+ ! pages 386 and 389 and Figure 8.3.1
+ do j=1,m2
+ do i=1,m1
+ E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
+ enddo
+ enddo
+ do k = 1,NGLLX
+ do j=1,m1
+ do i=1,m1
+ newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempx2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempx2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempx2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempx2(i,5,k)*hprimewgll_xx(5,j)
+ enddo
+ enddo
+ enddo
+ do j=1,m1
+ do i=1,m2
+ E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! sum contributions from each element to the global mesh and add gravity term
+ sum_terms = - (wgllwgll_yz(j,k)*newtempx1(i,j,k) &
+ + wgllwgll_xz(i,k)*newtempx2(i,j,k) &
+ + wgllwgll_xy(i,j)*newtempx3(i,j,k))
+
+ if(GRAVITY_VAL) sum_terms = sum_terms + gravity_term(i,j,k)
+
+ iglob = ibool(i,j,k,ispec)
+ accelfluid(iglob) = accelfluid(iglob) + sum_terms
+
+ enddo
+ enddo
+ enddo
+
+ ! update rotation term with Euler scheme
+ if(ROTATION_VAL) then
+ ! use the source saved above
+ A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + source_euler_A(:,:,:)
+ B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + source_euler_B(:,:,:)
+ endif
+
+ enddo ! spectral element loop
+
+ end subroutine compute_forces_outer_core_Dev
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_kernels.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_kernels.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_kernels.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_kernels.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1007 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine compute_kernels_crust_mantle(ibool_crust_mantle, &
+ rho_kl_crust_mantle,beta_kl_crust_mantle, &
+ alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
+ accel_crust_mantle,b_displ_crust_mantle, &
+ epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
+ deltat)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ rho_kl_crust_mantle, beta_kl_crust_mantle, alpha_kl_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ cijkl_kl_crust_mantle
+
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_displ_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
+ epsilondev_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ b_epsilondev_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
+ eps_trace_over_3_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ b_eps_trace_over_3_crust_mantle
+
+ real(kind=CUSTOM_REAL) deltat
+
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(21) :: prod !, cijkl_kl_local
+ real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
+ real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
+ integer :: i,j,k,ispec,iglob
+
+ ! crust_mantle
+ do ispec = 1, NSPEC_CRUST_MANTLE
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+
+ ! density kernel: see e.g. Tromp et al.(2005), equation (14)
+ ! b_displ_crust_mantle is the backward/reconstructed wavefield, that is s(x,t) in eq. (14),
+ ! accel_crust_mantle is the adjoint wavefield, that corresponds to s_dagger(x,T-t)
+ !
+ ! note with respect to eq. (14) the second time derivative is applied to the
+ ! adjoint wavefield here rather than the backward/reconstructed wavefield.
+ ! this is a valid operation and the resultant kernel identical to the eq. (14).
+ !
+ ! reason for this is that the adjoint wavefield is in general smoother
+ ! since the adjoint sources normally are obtained for filtered traces.
+ ! numerically, the time derivative by a finite-difference scheme should
+ ! behave better for smoother wavefields, thus containing less numerical artefacts.
+ rho_kl_crust_mantle(i,j,k,ispec) = rho_kl_crust_mantle(i,j,k,ispec) &
+ + deltat * (accel_crust_mantle(1,iglob) * b_displ_crust_mantle(1,iglob) &
+ + accel_crust_mantle(2,iglob) * b_displ_crust_mantle(2,iglob) &
+ + accel_crust_mantle(3,iglob) * b_displ_crust_mantle(3,iglob) )
+
+ epsilondev_loc(:) = epsilondev_crust_mantle(:,i,j,k,ispec)
+ b_epsilondev_loc(:) = b_epsilondev_crust_mantle(:,i,j,k,ispec)
+
+ ! For anisotropic kernels
+ if (ANISOTROPIC_KL) then
+
+ call compute_strain_product(prod,eps_trace_over_3_crust_mantle(i,j,k,ispec),epsilondev_loc, &
+ b_eps_trace_over_3_crust_mantle(i,j,k,ispec),b_epsilondev_loc)
+ cijkl_kl_crust_mantle(:,i,j,k,ispec) = cijkl_kl_crust_mantle(:,i,j,k,ispec) + deltat * prod(:)
+
+ else
+
+ ! kernel for shear modulus, see e.g. Tromp et al. (2005), equation (17)
+ ! note: multiplication with 2*mu(x) will be done after the time loop
+ beta_kl_crust_mantle(i,j,k,ispec) = beta_kl_crust_mantle(i,j,k,ispec) &
+ + deltat * (epsilondev_loc(1)*b_epsilondev_loc(1) + epsilondev_loc(2)*b_epsilondev_loc(2) &
+ + (epsilondev_loc(1)+epsilondev_loc(2)) * (b_epsilondev_loc(1)+b_epsilondev_loc(2)) &
+ + 2 * (epsilondev_loc(3)*b_epsilondev_loc(3) + epsilondev_loc(4)*b_epsilondev_loc(4) + &
+ epsilondev_loc(5)*b_epsilondev_loc(5)) )
+
+
+ ! kernel for bulk modulus, see e.g. Tromp et al. (2005), equation (18)
+ ! note: multiplication with kappa(x) will be done after the time loop
+ alpha_kl_crust_mantle(i,j,k,ispec) = alpha_kl_crust_mantle(i,j,k,ispec) &
+ + deltat * (9 * eps_trace_over_3_crust_mantle(i,j,k,ispec) &
+ * b_eps_trace_over_3_crust_mantle(i,j,k,ispec))
+
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+
+ end subroutine compute_kernels_crust_mantle
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine compute_kernels_outer_core(ibool_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ displ_outer_core,accel_outer_core, &
+ b_displ_outer_core,b_accel_outer_core, &
+ vector_accel_outer_core,vector_displ_outer_core, &
+ b_vector_displ_outer_core, &
+ div_displ_outer_core,b_div_displ_outer_core, &
+ rhostore_outer_core,kappavstore_outer_core, &
+ rho_kl_outer_core,alpha_kl_outer_core, &
+ deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
+ deltat)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ 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(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
+ displ_outer_core,accel_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
+ b_displ_outer_core,b_accel_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_OUTER_CORE) :: vector_accel_outer_core,&
+ vector_displ_outer_core, b_vector_displ_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: div_displ_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: b_div_displ_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
+ rhostore_outer_core,kappavstore_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: &
+ rho_kl_outer_core,alpha_kl_outer_core
+
+ integer nspec_beta_kl_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_beta_kl_outer_core) :: &
+ beta_kl_outer_core
+ logical deviatoric_outercore
+
+ real(kind=CUSTOM_REAL) deltat
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,kappal
+ real(kind=CUSTOM_REAL) :: tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) :: tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) :: tempz1l,tempz2l,tempz3l
+ real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
+ real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
+
+ integer :: i,j,k,l,ispec,iglob
+
+ ! outer_core -- compute the actual displacement and acceleration (NDIM,NGLOBMAX_OUTER_CORE)
+ do ispec = 1, NSPEC_OUTER_CORE
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool_outer_core(i,j,k,ispec)
+
+ xixl = xix_outer_core(i,j,k,ispec)
+ xiyl = xiy_outer_core(i,j,k,ispec)
+ xizl = xiz_outer_core(i,j,k,ispec)
+ etaxl = etax_outer_core(i,j,k,ispec)
+ etayl = etay_outer_core(i,j,k,ispec)
+ etazl = etaz_outer_core(i,j,k,ispec)
+ gammaxl = gammax_outer_core(i,j,k,ispec)
+ gammayl = gammay_outer_core(i,j,k,ispec)
+ gammazl = gammaz_outer_core(i,j,k,ispec)
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+
+ do l=1,NGLLX
+ tempx1l = tempx1l + b_displ_outer_core(ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
+ enddo
+
+ do l=1,NGLLY
+ tempx2l = tempx2l + b_displ_outer_core(ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
+ enddo
+
+ do l=1,NGLLZ
+ tempx3l = tempx3l + b_displ_outer_core(ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
+ enddo
+
+ b_vector_displ_outer_core(1,iglob) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ b_vector_displ_outer_core(2,iglob) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ b_vector_displ_outer_core(3,iglob) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+
+ !deviatoric kernel check
+ if( deviatoric_outercore ) then
+
+ 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
+
+ ! assumes NGLLX = NGLLY = NGLLZ
+ do l=1,NGLLX
+ tempx1l = tempx1l + b_vector_displ_outer_core(1,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
+ tempy1l = tempy1l + b_vector_displ_outer_core(2,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
+ tempz1l = tempz1l + b_vector_displ_outer_core(3,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
+
+ tempx2l = tempx2l + b_vector_displ_outer_core(1,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
+ tempy2l = tempy2l + b_vector_displ_outer_core(2,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
+ tempz2l = tempz2l + b_vector_displ_outer_core(3,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
+
+ tempx3l = tempx3l + b_vector_displ_outer_core(1,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
+ tempy3l = tempy3l + b_vector_displ_outer_core(2,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
+ tempz3l = tempz3l + b_vector_displ_outer_core(3,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
+ enddo
+
+
+ !deviatoric strain
+ b_epsilondev_loc(1) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
+
+ b_epsilondev_loc(2) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
+
+ b_epsilondev_loc(3) = 0.5*( xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l &
+ + xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l ) &
+ - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
+
+ b_epsilondev_loc(4) = 0.5*( xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l &
+ + xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l ) &
+ - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
+
+ b_epsilondev_loc(5) = 0.5*( xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l &
+ + xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l ) &
+ - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
+
+ endif !deviatoric kernel check
+
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ tempx1l = tempx1l + accel_outer_core(ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
+ enddo
+
+ do l=1,NGLLY
+ tempx2l = tempx2l + accel_outer_core(ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
+ enddo
+
+ do l=1,NGLLZ
+ tempx3l = tempx3l + accel_outer_core(ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
+ enddo
+
+ vector_accel_outer_core(1,iglob) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ vector_accel_outer_core(2,iglob) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ vector_accel_outer_core(3,iglob) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ tempx1l = tempx1l + displ_outer_core(ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
+ enddo
+
+ do l=1,NGLLY
+ tempx2l = tempx2l + displ_outer_core(ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
+ enddo
+
+ do l=1,NGLLZ
+ tempx3l = tempx3l + displ_outer_core(ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
+ enddo
+
+ vector_displ_outer_core(1,iglob) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ vector_displ_outer_core(2,iglob) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ vector_displ_outer_core(3,iglob) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+
+ !deviatoric kernel check
+ if( deviatoric_outercore ) then
+
+ 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
+
+ ! assumes NGLLX = NGLLY = NGLLZ
+ do l=1,NGLLX
+ tempx1l = tempx1l + vector_displ_outer_core(1,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
+ tempy1l = tempy1l + vector_displ_outer_core(2,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
+ tempz1l = tempz1l + vector_displ_outer_core(3,ibool_outer_core(l,j,k,ispec)) * hprime_xx(i,l)
+
+ tempx2l = tempx2l + vector_displ_outer_core(1,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
+ tempy2l = tempy2l + vector_displ_outer_core(2,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
+ tempz2l = tempz2l + vector_displ_outer_core(3,ibool_outer_core(i,l,k,ispec)) * hprime_yy(j,l)
+
+ tempx3l = tempx3l + vector_displ_outer_core(1,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
+ tempy3l = tempy3l + vector_displ_outer_core(2,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
+ tempz3l = tempz3l + vector_displ_outer_core(3,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
+ enddo
+
+
+ !deviatoric strain
+ epsilondev_loc(1) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
+
+ epsilondev_loc(2) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
+
+ epsilondev_loc(3) = 0.5*( xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l &
+ + xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l ) &
+ - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
+
+ epsilondev_loc(4) = 0.5*( xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l &
+ + xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l ) &
+ - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
+
+ epsilondev_loc(5) = 0.5*( xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l &
+ + xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l ) &
+ - ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ + xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ + xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
+
+ beta_kl_outer_core(i,j,k,ispec) = beta_kl_outer_core(i,j,k,ispec) &
+ + deltat * (epsilondev_loc(1)*b_epsilondev_loc(1) + epsilondev_loc(2)*b_epsilondev_loc(2) &
+ + (epsilondev_loc(1)+epsilondev_loc(2)) * (b_epsilondev_loc(1)+b_epsilondev_loc(2)) &
+ + 2 * (epsilondev_loc(3)*b_epsilondev_loc(3) + epsilondev_loc(4)*b_epsilondev_loc(4) + &
+ epsilondev_loc(5)*b_epsilondev_loc(5)) )
+
+ endif !deviatoric kernel check
+
+
+
+ rho_kl_outer_core(i,j,k,ispec) = rho_kl_outer_core(i,j,k,ispec) &
+ + deltat * dot_product(vector_accel_outer_core(:,iglob), b_vector_displ_outer_core(:,iglob))
+
+ kappal = rhostore_outer_core(i,j,k,ispec)/kappavstore_outer_core(i,j,k,ispec)
+
+ div_displ_outer_core(i,j,k,ispec) = kappal * accel_outer_core(iglob)
+ b_div_displ_outer_core(i,j,k,ispec) = kappal * b_accel_outer_core(iglob)
+
+ alpha_kl_outer_core(i,j,k,ispec) = alpha_kl_outer_core(i,j,k,ispec) &
+ + deltat * div_displ_outer_core(i,j,k,ispec) * b_div_displ_outer_core(i,j,k,ispec)
+
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_kernels_outer_core
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine compute_kernels_inner_core(ibool_inner_core, &
+ rho_kl_inner_core,beta_kl_inner_core, &
+ alpha_kl_inner_core, &
+ accel_inner_core,b_displ_inner_core, &
+ epsilondev_inner_core,b_epsilondev_inner_core, &
+ eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
+ deltat)
+
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
+ rho_kl_inner_core, beta_kl_inner_core, alpha_kl_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
+ accel_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
+ b_displ_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: &
+ epsilondev_inner_core
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
+ b_epsilondev_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STRAIN_ONLY) :: &
+ eps_trace_over_3_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
+ b_eps_trace_over_3_inner_core
+
+ real(kind=CUSTOM_REAL) deltat
+
+ ! local parameters
+ real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
+ real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
+
+ integer :: i,j,k,ispec,iglob
+
+
+ ! inner_core
+ do ispec = 1, NSPEC_INNER_CORE
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool_inner_core(i,j,k,ispec)
+
+ rho_kl_inner_core(i,j,k,ispec) = rho_kl_inner_core(i,j,k,ispec) &
+ + deltat * (accel_inner_core(1,iglob) * b_displ_inner_core(1,iglob) &
+ + accel_inner_core(2,iglob) * b_displ_inner_core(2,iglob) &
+ + accel_inner_core(3,iglob) * b_displ_inner_core(3,iglob) )
+
+ epsilondev_loc(:) = epsilondev_inner_core(:,i,j,k,ispec)
+ b_epsilondev_loc(:) = b_epsilondev_inner_core(:,i,j,k,ispec)
+ beta_kl_inner_core(i,j,k,ispec) = beta_kl_inner_core(i,j,k,ispec) &
+ + deltat * (epsilondev_loc(1)*b_epsilondev_loc(1) + epsilondev_loc(2)*b_epsilondev_loc(2) &
+ + (epsilondev_loc(1)+epsilondev_loc(2)) * (b_epsilondev_loc(1)+b_epsilondev_loc(2)) &
+ + 2 * (epsilondev_loc(3)*b_epsilondev_loc(3) + epsilondev_loc(4)*b_epsilondev_loc(4) &
+ + epsilondev_loc(5)*b_epsilondev_loc(5)) )
+
+ alpha_kl_inner_core(i,j,k,ispec) = alpha_kl_inner_core(i,j,k,ispec) &
+ + deltat * (9 * eps_trace_over_3_inner_core(i,j,k,ispec) * b_eps_trace_over_3_inner_core(i,j,k,ispec))
+ enddo
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_kernels_inner_core
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+! Subroutines to compute the kernels for the 21 elastic coefficients
+! Last modified 19/04/2007
+
+!-------------------------------------------------------------------
+ subroutine compute_strain_product(prod,eps_trace_over_3,epsdev,&
+ b_eps_trace_over_3,b_epsdev)
+
+ ! Purpose : compute the 21 strain products at a grid point
+ ! (ispec,i,j,k fixed) and at a time t to compute then the kernels cij_kl (Voigt notation)
+ ! (eq. 15 of Tromp et al., 2005)
+ ! prod(1)=eps11*eps11 -> c11, prod(2)=eps11eps22 -> c12, prod(3)=eps11eps33 -> c13, ...
+ ! prod(7)=eps22*eps22 -> c22, prod(8)=eps22eps33 -> c23, prod(9)=eps22eps23 -> c24, ...
+ ! prod(19)=eps13*eps13 -> c55, prod(20)=eps13eps12 -> c56, prod(21)=eps12eps12 -> c66
+ ! This then gives how the 21 kernels are organized
+ ! For crust_mantle
+
+ ! Modif 09/11/2005
+
+ implicit none
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL),dimension(21) :: prod
+ real(kind=CUSTOM_REAL) :: eps_trace_over_3,b_eps_trace_over_3
+ real(kind=CUSTOM_REAL),dimension(5) :: epsdev,b_epsdev
+
+ real(kind=CUSTOM_REAL), dimension(6) :: eps,b_eps
+ integer :: p,i,j
+
+ ! Building of the local matrix of the strain tensor
+ ! for the adjoint field and the regular backward field
+ eps(1:2)=epsdev(1:2)+eps_trace_over_3 !eps11 et eps22
+ eps(3)=-(eps(1)+eps(2))+3*eps_trace_over_3 !eps33
+ eps(4)=epsdev(5) !eps23
+ eps(5)=epsdev(4) !eps13
+ eps(6)=epsdev(3) !eps12
+
+ b_eps(1:2)=b_epsdev(1:2)+b_eps_trace_over_3
+ b_eps(3)=-(b_eps(1)+b_eps(2))+3*b_eps_trace_over_3
+ b_eps(4)=b_epsdev(5)
+ b_eps(5)=b_epsdev(4)
+ b_eps(6)=b_epsdev(3)
+
+ ! Computing the 21 strain products without assuming eps(i)*b_eps(j) = eps(j)*b_eps(i)
+ p=1
+ do i=1,6
+ do j=i,6
+ prod(p)=eps(i)*b_eps(j)
+ if(j>i) then
+ prod(p)=prod(p)+eps(j)*b_eps(i)
+ if(j>3 .and. i<4) prod(p)=prod(p)*2
+ endif
+ if(i>3) prod(p)=prod(p)*4
+ p=p+1
+ enddo
+ enddo
+
+ end subroutine compute_strain_product
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine rotate_kernels_dble(cij_kl,cij_kll,theta_in,phi_in)
+
+! Purpose : compute the kernels in r,theta,phi (cij_kll)
+! from the kernels in x,y,z (cij_kl) (x,y,z <-> r,theta,phi)
+! At r,theta,phi fixed
+! theta and phi are in radians
+
+! Coeff from Min's routine rotate_anisotropic_tensor
+! with the help of Collect[Expand[cij],{dij}] in Mathematica
+
+! Definition of the output array cij_kll :
+! cij_kll(1) = C11 ; cij_kll(2) = C12 ; cij_kll(3) = C13
+! cij_kll(4) = C14 ; cij_kll(5) = C15 ; cij_kll(6) = C16
+! cij_kll(7) = C22 ; cij_kll(8) = C23 ; cij_kll(9) = C24
+! cij_kll(10) = C25 ; cij_kll(11) = C26 ; cij_kll(12) = C33
+! cij_kll(13) = C34 ; cij_kll(14) = C35 ; cij_kll(15) = C36
+! cij_kll(16) = C44 ; cij_kll(17) = C45 ; cij_kll(18) = C46
+! cij_kll(19) = C55 ; cij_kll(20) = C56 ; cij_kll(21) = C66
+! where the Cij (Voigt's notation) are defined as function of
+! the components of the elastic tensor in spherical coordinates
+! by eq. (A.1) of Chen & Tromp, GJI 168 (2007)
+
+ implicit none
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) :: theta_in,phi_in
+ real(kind=CUSTOM_REAL),dimension(21) :: cij_kll,cij_kl
+
+ double precision :: theta,phi
+ double precision :: costheta,sintheta,cosphi,sinphi
+ double precision :: costhetasq,sinthetasq,cosphisq,sinphisq
+ double precision :: costwotheta,sintwotheta,costwophi,sintwophi
+ double precision :: cosfourtheta,sinfourtheta,cosfourphi,sinfourphi
+ double precision :: costhetafour,sinthetafour,cosphifour,sinphifour
+ double precision :: sintwophisq,sintwothetasq
+ double precision :: costhreetheta,sinthreetheta,costhreephi,sinthreephi
+
+
+ if (CUSTOM_REAL == SIZE_REAL) then
+ theta = dble(theta_in)
+ phi = dble(phi_in)
+ else
+ theta = theta_in
+ phi = phi_in
+ endif
+
+ 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)
+
+ costhreetheta=dcos(3.d0*theta)
+ sinthreetheta=dsin(3.d0*theta)
+ costhreephi=dcos(3.d0*phi)
+ sinthreephi=dsin(3.d0*phi)
+
+ cosfourtheta = dcos(4.d0*theta)
+ sinfourtheta = dsin(4.d0*theta)
+ cosfourphi = dcos(4.d0*phi)
+ sinfourphi = dsin(4.d0*phi)
+ sintwothetasq = sintwotheta * sintwotheta
+ sintwophisq = sintwophi * sintwophi
+
+
+ cij_kll(1) = 1.d0/16.d0* (cij_kl(16) - cij_kl(16)* costwophi + &
+ 16.d0* cosphi*cosphisq* costhetafour* (cij_kl(1)* cosphi + cij_kl(6)* sinphi) + &
+ 2.d0* (cij_kl(15) + cij_kl(17))* sintwophi* sintwothetasq - &
+ 2.d0* (cij_kl(16)* cosfourtheta* sinphisq + &
+ 2.d0* costhetafour* (-4* cij_kl(7)* sinphifour - &
+ (cij_kl(2) + cij_kl(21))* sintwophisq) + &
+ 8.d0* cij_kl(5)* cosphi*cosphisq* costheta*costhetasq* sintheta - &
+ 8.d0* cij_kl(8)* costhetasq* sinphisq* sinthetasq - &
+ 8.d0* cij_kl(12)* sinthetafour + &
+ 8.d0* cosphisq* costhetasq* sintheta* ((cij_kl(4) + &
+ cij_kl(20))* costheta* sinphi - &
+ (cij_kl(3) + cij_kl(19))*sintheta) + &
+ 8.d0* cosphi* costheta* (-cij_kl(11)* costheta*costhetasq* &
+ sinphi*sinphisq + (cij_kl(10) + cij_kl(18))* costhetasq* sinphisq* sintheta + &
+ cij_kl(14)* sintheta*sinthetasq) + 2.d0* sinphi* (cij_kl(13) + &
+ cij_kl(9)* sinphisq)* sintwotheta + &
+ sinphi* (-cij_kl(13) + cij_kl(9)* sinphisq)* sinfourtheta))
+
+ cij_kll(2) = 1.d0/4.d0* (costhetasq* (cij_kl(1) + 3.d0* cij_kl(2) + cij_kl(7) - &
+ cij_kl(21) + (-cij_kl(1) + cij_kl(2) - cij_kl(7) + &
+ cij_kl(21))* cosfourphi + (-cij_kl(6) + cij_kl(11))* sinfourphi) + &
+ 4.d0* (cij_kl(8)* cosphisq - cij_kl(15)* cosphi* sinphi + &
+ cij_kl(3)* sinphisq)* sinthetasq - &
+ 2.d0* (cij_kl(10)* cosphisq*cosphi + &
+ (cij_kl(9) - cij_kl(20))* cosphisq* sinphi + &
+ (cij_kl(5) - cij_kl(18))* cosphi* sinphisq + &
+ cij_kl(4)* sinphisq*sinphi)* sintwotheta)
+
+ cij_kll(3) = 1.d0/8.d0* (sintwophi* (3.d0* cij_kl(15) - cij_kl(17) + &
+ 4.d0* (cij_kl(2) + cij_kl(21))* costhetasq* sintwophi* sinthetasq) + &
+ 4.d0* cij_kl(12)* sintwothetasq + 4.d0* cij_kl(1)* cosphifour* sintwothetasq + &
+ 2.d0* cosphi*cosphisq* (8.d0* cij_kl(6)* costhetasq* sinphi* sinthetasq + &
+ cij_kl(5)* sinfourtheta) + 2.d0* cosphisq* (3.d0* cij_kl(3) - cij_kl(19) + &
+ (cij_kl(3) + cij_kl(19))* cosfourtheta + &
+ (cij_kl(4) + cij_kl(20))* sinphi* sinfourtheta) + &
+ 2.d0* sinphi* (sinphi* (3.d0* cij_kl(8) - &
+ cij_kl(16) + (cij_kl(8) + cij_kl(16))* cosfourtheta + &
+ 2.d0* cij_kl(7)* sinphisq* sintwothetasq)+ &
+ (-cij_kl(13) + cij_kl(9)* sinphisq)* sinfourtheta)+ &
+ 2.d0* cosphi* ((cij_kl(15) + cij_kl(17))* cosfourtheta* sinphi + &
+ 8.d0* cij_kl(11)* costhetasq* sinphi*sinphisq* sinthetasq + &
+ (-cij_kl(14) + (cij_kl(10) + cij_kl(18))* sinphisq)*sinfourtheta))
+
+ cij_kll(4) = 1.d0/8.d0* (cosphi* costheta *(5.d0* cij_kl(4) - &
+ cij_kl(9) + 4.d0* cij_kl(13) - &
+ 3.d0* cij_kl(20) + (cij_kl(4) + 3.d0* cij_kl(9) - &
+ 4.d0* cij_kl(13) + cij_kl(20))* costwotheta) + &
+ 1.d0/2.d0* (cij_kl(4) - cij_kl(9) + &
+ cij_kl(20))* costhreephi * (costheta + 3.d0* costhreetheta) - &
+ costheta* (-cij_kl(5) + 5.d0* cij_kl(10) + &
+ 4.d0* cij_kl(14) - 3.d0* cij_kl(18) + &
+ (3.d0* cij_kl(5) + cij_kl(10) - &
+ 4.d0* cij_kl(14) + cij_kl(18))* costwotheta)* sinphi - &
+ 1.d0/2.d0* (cij_kl(5) - cij_kl(10) - cij_kl(18))* (costheta + &
+ 3.d0* costhreetheta)* sinthreephi + &
+ 4.d0* (cij_kl(6) - cij_kl(11))* cosfourphi* costhetasq* sintheta - &
+ 4.d0* (cij_kl(1) + cij_kl(3) - cij_kl(7) - cij_kl(8) + cij_kl(16) - cij_kl(19) + &
+ (cij_kl(1) - cij_kl(3) - cij_kl(7) + cij_kl(8) + &
+ cij_kl(16) - cij_kl(19))* costwotheta)* sintwophi* sintheta - &
+ 4.d0* (cij_kl(1) - cij_kl(2) + cij_kl(7) - &
+ cij_kl(21))* costhetasq* sinfourphi* sintheta + &
+ costwophi* ((cij_kl(6) + cij_kl(11) + 6.d0* cij_kl(15) - &
+ 2.d0* cij_kl(17))* sintheta + &
+ (cij_kl(6) + cij_kl(11) - 2.d0* (cij_kl(15) + cij_kl(17)))* sinthreetheta))
+
+ cij_kll(5) = 1.d0/4.d0* (2.d0* (cij_kl(4) + &
+ cij_kl(20))* cosphisq* (costwotheta + cosfourtheta)* sinphi + &
+ 2.d0* cij_kl(9)* (costwotheta + cosfourtheta)* sinphi*sinphisq + &
+ 16.d0* cij_kl(1)* cosphifour* costheta*costhetasq* sintheta + &
+ 4.d0* costheta*costhetasq* (-2.d0* cij_kl(8)* sinphisq + &
+ 4.d0* cij_kl(7)* sinphifour + &
+ (cij_kl(2) + cij_kl(21))* sintwophisq)* sintheta + &
+ 4.d0* cij_kl(13)* (1.d0 + 2.d0* costwotheta)* sinphi* sinthetasq + &
+ 8.d0* costheta* (-2.d0* cij_kl(12) + cij_kl(8)* sinphisq)* sintheta*sinthetasq + &
+ 2.d0* cosphi*cosphisq* (cij_kl(5)* (costwotheta + cosfourtheta) + &
+ 8.d0* cij_kl(6)* costheta*costhetasq* sinphi* sintheta) + &
+ 2.d0* cosphi* (cosfourtheta* (-cij_kl(14) + (cij_kl(10) + cij_kl(18))* sinphisq) + &
+ costwotheta* (cij_kl(14) + (cij_kl(10) + cij_kl(18))* sinphisq) + &
+ 8.d0* cij_kl(11)* costheta*costhetasq* sinphi*sinphisq* sintheta) - &
+ (cij_kl(3) + cij_kl(16) + cij_kl(19) + &
+ (cij_kl(3) - cij_kl(16) + cij_kl(19))* costwophi + &
+ (cij_kl(15) + cij_kl(17))* sintwophi)* sinfourtheta)
+
+ cij_kll(6) = 1.d0/2.d0* costheta*costhetasq* ((cij_kl(6) + cij_kl(11))* costwophi + &
+ (cij_kl(6) - cij_kl(11))* cosfourphi + 2.d0* (-cij_kl(1) + cij_kl(7))* sintwophi + &
+ (-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(21))* sinfourphi) + &
+ 1.d0/4.d0* costhetasq* (-(cij_kl(4) + 3* cij_kl(9) + cij_kl(20))* cosphi - &
+ 3.d0* (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi + &
+ (3.d0* cij_kl(5) + cij_kl(10) + cij_kl(18))* sinphi + &
+ 3.d0* (cij_kl(5) - cij_kl(10) - cij_kl(18))* sinthreephi)* sintheta + &
+ costheta* ((cij_kl(15) + cij_kl(17))* costwophi + &
+ (-cij_kl(3) + cij_kl(8) + cij_kl(16) - cij_kl(19))* sintwophi)* sinthetasq + &
+ (-cij_kl(13)* cosphi + cij_kl(14)* sinphi)* sintheta*sinthetasq
+
+ cij_kll(7) = cij_kl(7)* cosphifour - cij_kl(11)* cosphi*cosphisq* sinphi + &
+ (cij_kl(2) + cij_kl(21))* cosphisq* sinphisq - &
+ cij_kl(6)* cosphi* sinphi*sinphisq + &
+ cij_kl(1)* sinphifour
+
+ cij_kll(8) = 1.d0/2.d0* (2.d0* costhetasq* sinphi* (-cij_kl(15)* cosphi + &
+ cij_kl(3)* sinphi) + 2.d0* cij_kl(2)* cosphifour* sinthetasq + &
+ (2.d0* cij_kl(2)* sinphifour + &
+ (cij_kl(1) + cij_kl(7) - cij_kl(21))* sintwophisq)* sinthetasq + &
+ cij_kl(4)* sinphi*sinphisq* sintwotheta + &
+ cosphi*cosphisq* (2.d0* (-cij_kl(6) + cij_kl(11))* sinphi* sinthetasq + &
+ cij_kl(10)* sintwotheta) + cosphi* sinphisq* (2.d0* (cij_kl(6) - &
+ cij_kl(11))* sinphi* sinthetasq + &
+ (cij_kl(5) - cij_kl(18))* sintwotheta) + &
+ cosphisq* (2.d0* cij_kl(8)* costhetasq + &
+ (cij_kl(9) - cij_kl(20))* sinphi* sintwotheta))
+
+ cij_kll(9) = cij_kl(11)* cosphifour* sintheta - sinphi*sinphisq* (cij_kl(5)* costheta + &
+ cij_kl(6)* sinphi* sintheta) + cosphisq* sinphi* (-(cij_kl(10) + &
+ cij_kl(18))* costheta + &
+ 3.d0* (cij_kl(6) - cij_kl(11))* sinphi* sintheta) + &
+ cosphi* sinphisq* ((cij_kl(4) + cij_kl(20))* costheta + &
+ 2.d0* (-2.d0* cij_kl(1) + cij_kl(2) + cij_kl(21))* sinphi* sintheta) + &
+ cosphi*cosphisq* (cij_kl(9)* costheta - 2.d0* (cij_kl(2) - 2.d0* cij_kl(7) + &
+ cij_kl(21))* sinphi* sintheta)
+
+ cij_kll(10) = 1.d0/4.d0* (4.d0* costwotheta* (cij_kl(10)* cosphi*cosphisq + &
+ (cij_kl(9) - cij_kl(20))* cosphisq* sinphi + &
+ (cij_kl(5) - cij_kl(18))* cosphi* sinphisq + &
+ cij_kl(4)* sinphi*sinphisq) + (cij_kl(1) + 3.d0* cij_kl(2) - &
+ 2.d0* cij_kl(3) + cij_kl(7) - &
+ 2.d0* cij_kl(8) - cij_kl(21) + 2.d0* (cij_kl(3) - cij_kl(8))* costwophi + &
+ (-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(21))* cosfourphi + &
+ 2.d0* cij_kl(15)* sintwophi + &
+ (-cij_kl(6) + cij_kl(11))* sinfourphi)* sintwotheta)
+
+ cij_kll(11) = 1.d0/4.d0* (2.d0* costheta* ((cij_kl(6) + cij_kl(11))* costwophi + &
+ (-cij_kl(6) + cij_kl(11))* cosfourphi + &
+ 2.d0* (-cij_kl(1) + cij_kl(7))* sintwophi + &
+ (cij_kl(1) - cij_kl(2) + cij_kl(7) - cij_kl(21))* sinfourphi) + &
+ (-(cij_kl(4) + 3.d0* cij_kl(9) + cij_kl(20))* cosphi + &
+ (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi + &
+ (3.d0* cij_kl(5) + cij_kl(10) + cij_kl(18))* sinphi + &
+ (-cij_kl(5) + cij_kl(10) + cij_kl(18))* sinthreephi)* sintheta)
+
+ cij_kll(12) = 1.d0/16.d0* (cij_kl(16) - 2.d0* cij_kl(16)* cosfourtheta* sinphisq + &
+ costwophi* (-cij_kl(16) + 8.d0* costheta* sinthetasq* ((cij_kl(3) - &
+ cij_kl(8) + cij_kl(19))* costheta + &
+ (cij_kl(5) - cij_kl(10) - cij_kl(18))* cosphi* sintheta)) + &
+ 2.d0* (cij_kl(15) + cij_kl(17))* sintwophi* sintwothetasq + &
+ 2.d0* (8.d0* cij_kl(12)* costhetafour + &
+ 8.d0* cij_kl(14)* cosphi* costheta*costhetasq* sintheta + &
+ 4.d0* cosphi* costheta* (cij_kl(5) + cij_kl(10) + cij_kl(18) + &
+ (cij_kl(4) + cij_kl(20))* sintwophi)* &
+ sintheta*sinthetasq + 8.d0* cij_kl(1)* cosphifour* sinthetafour + &
+ 8.d0* cij_kl(6)* cosphi*cosphisq* sinphi* sinthetafour + &
+ 8.d0* cij_kl(11)* cosphi* sinphi*sinphisq* sinthetafour + &
+ 8.d0* cij_kl(7)* sinphifour* sinthetafour + &
+ 2.d0* cij_kl(2)* sintwophisq* sinthetafour + &
+ 2.d0* cij_kl(21)* sintwophisq* sinthetafour + &
+ 2.d0* cij_kl(13)* sinphi* sintwotheta + &
+ 2.d0* cij_kl(9)* sinphi*sinphisq* sintwotheta + &
+ cij_kl(3)* sintwothetasq + cij_kl(8)* sintwothetasq + &
+ cij_kl(19)* sintwothetasq + cij_kl(13)* sinphi* sinfourtheta - &
+ cij_kl(9)* sinphi*sinphisq* sinfourtheta))
+
+ cij_kll(13) = 1.d0/8.d0* (cosphi* costheta* (cij_kl(4) + 3.d0* cij_kl(9) + &
+ 4.d0* cij_kl(13) + cij_kl(20) - (cij_kl(4) + 3.d0* cij_kl(9) - &
+ 4.d0* cij_kl(13) + cij_kl(20))* costwotheta) + 4.d0* (-cij_kl(1) - &
+ cij_kl(3) + cij_kl(7) + cij_kl(8) + cij_kl(16) - cij_kl(19) + &
+ (cij_kl(1) - cij_kl(3) - cij_kl(7) + cij_kl(8) + cij_kl(16) - &
+ cij_kl(19))* costwotheta)* sintwophi* sintheta + &
+ 4.d0* (cij_kl(6) - cij_kl(11))* cosfourphi* sinthetasq*sintheta - &
+ 4.d0* (cij_kl(1) - cij_kl(2) + cij_kl(7) - &
+ cij_kl(21))* sinfourphi* sinthetasq*sintheta + &
+ costheta* ((-3.d0* cij_kl(5) - cij_kl(10) - 4.d0* cij_kl(14) - &
+ cij_kl(18) + (3.d0* cij_kl(5) + cij_kl(10) - 4.d0* cij_kl(14) + &
+ cij_kl(18))* costwotheta)* sinphi + 6.d0* ((cij_kl(4) - cij_kl(9) + &
+ cij_kl(20))* costhreephi + (-cij_kl(5) + cij_kl(10) + &
+ cij_kl(18))* sinthreephi)* sinthetasq) + costwophi* ((3* cij_kl(6) + &
+ 3.d0* cij_kl(11) + 2.d0* (cij_kl(15) + cij_kl(17)))* sintheta - &
+ (cij_kl(6) + cij_kl(11) - 2.d0* (cij_kl(15) + &
+ cij_kl(17)))* sinthreetheta))
+
+ cij_kll(14) = 1.d0/4.d0* (2.d0* cij_kl(13)* (costwotheta + cosfourtheta)* sinphi + &
+ 8.d0* costheta*costhetasq* (-2.d0* cij_kl(12) + cij_kl(8)* sinphisq)* sintheta + &
+ 4.d0* (cij_kl(4) + cij_kl(20))* cosphisq* (1.d0 + &
+ 2.d0* costwotheta)* sinphi* sinthetasq + &
+ 4.d0* cij_kl(9)* (1.d0 + 2.d0* costwotheta)* sinphi*sinphisq* sinthetasq + &
+ 16.d0* cij_kl(1)* cosphifour* costheta* sintheta*sinthetasq + &
+ 4.d0* costheta* (-2.d0* cij_kl(8)* sinphisq + 4.d0* cij_kl(7)* sinphifour + &
+ (cij_kl(2) + cij_kl(21))* sintwophisq)* sintheta*sinthetasq + &
+ 4.d0* cosphi*cosphisq* sinthetasq* (cij_kl(5) + 2.d0* cij_kl(5)* costwotheta + &
+ 4.d0* cij_kl(6)* costheta* sinphi* sintheta) + &
+ 2.d0* cosphi* (cosfourtheta* (cij_kl(14) - (cij_kl(10) + cij_kl(18))* sinphisq) + &
+ costwotheta* (cij_kl(14) + (cij_kl(10) + cij_kl(18))* sinphisq) + &
+ 8.d0* cij_kl(11)* costheta* sinphi*sinphisq* sintheta*sinthetasq) + &
+ (cij_kl(3) + cij_kl(16) + cij_kl(19) + (cij_kl(3) - cij_kl(16) + &
+ cij_kl(19))* costwophi + (cij_kl(15) + cij_kl(17))* sintwophi)* sinfourtheta)
+
+ cij_kll(15) = costwophi* costheta* (-cij_kl(17) + (cij_kl(15) + cij_kl(17))* costhetasq) + &
+ 1.d0/16.d0* (-((11.d0* cij_kl(4) + cij_kl(9) + 4.d0* cij_kl(13) - &
+ 5.d0* cij_kl(20))* cosphi + (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi - &
+ (cij_kl(5) + 11.d0* cij_kl(10) + 4.d0* cij_kl(14) - &
+ 5.d0* cij_kl(18))* sinphi + (-cij_kl(5) + cij_kl(10) + &
+ cij_kl(18))* sinthreephi)* sintheta + &
+ 8.d0* costheta* ((-cij_kl(1) - cij_kl(3) + cij_kl(7) + cij_kl(8) - cij_kl(16) +&
+ cij_kl(19) + (cij_kl(1) - cij_kl(3) - &
+ cij_kl(7) + cij_kl(8) + cij_kl(16) - cij_kl(19))* costwotheta)* sintwophi +&
+ ((cij_kl(6) + cij_kl(11))* costwophi + &
+ (cij_kl(6) - cij_kl(11))* cosfourphi + (-cij_kl(1) + cij_kl(2) - cij_kl(7) +&
+ cij_kl(21))* sinfourphi)* sinthetasq) +&
+ ((cij_kl(4) + 3.d0* cij_kl(9) - 4.d0* cij_kl(13) + cij_kl(20))* cosphi + &
+ 3.d0* (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi - &
+ (3.d0* cij_kl(5) + cij_kl(10) - 4.d0* cij_kl(14) + cij_kl(18))* sinphi + &
+ 3.d0* (-cij_kl(5) + cij_kl(10) + cij_kl(18))* sinthreephi)* sinthreetheta)
+
+ cij_kll(16) = 1.d0/4.d0*(cij_kl(1) - cij_kl(2) + cij_kl(7) + cij_kl(16) + &
+ cij_kl(19) + cij_kl(21) + 2.d0*(cij_kl(16) - cij_kl(19))*costwophi* costhetasq + &
+ (-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(16) + &
+ cij_kl(19) - cij_kl(21))*costwotheta - 2.d0* cij_kl(17)* costhetasq* sintwophi + &
+ 2.d0* ((-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(21))* cosfourphi + &
+ (-cij_kl(6) + cij_kl(11))* sinfourphi)* sinthetasq + ((cij_kl(5) - cij_kl(10) +&
+ cij_kl(18))* cosphi + (-cij_kl(5) + cij_kl(10) + cij_kl(18))* costhreephi +&
+ (-cij_kl(4) + cij_kl(9) + cij_kl(20))* sinphi - &
+ (cij_kl(4) - cij_kl(9) + cij_kl(20))* sinthreephi)* sintwotheta)
+
+ cij_kll(17) = 1.d0/8.d0* (4.d0* costwophi* costheta* (cij_kl(6) + cij_kl(11) - &
+ 2.d0* cij_kl(15) - (cij_kl(6) + cij_kl(11) - 2.d0* (cij_kl(15) + &
+ cij_kl(17)))* costwotheta) - (2.d0* cosphi* (-3.d0* cij_kl(4) +&
+ cij_kl(9) + 2.d0* cij_kl(13) + cij_kl(20) + (cij_kl(4) - cij_kl(9) + &
+ cij_kl(20))* costwophi) - (cij_kl(5) - 5.d0* cij_kl(10) + &
+ 4.d0* cij_kl(14) + 3.d0* cij_kl(18))* sinphi + (-cij_kl(5) + cij_kl(10) + &
+ cij_kl(18))* sinthreephi)* sintheta + &
+ 8.d0* costheta* ((-cij_kl(1) + cij_kl(3) + cij_kl(7) - cij_kl(8) + &
+ (cij_kl(1) - cij_kl(3) - cij_kl(7) + cij_kl(8) + cij_kl(16) - &
+ cij_kl(19))* costwotheta)* sintwophi + ((cij_kl(6) - cij_kl(11))* cosfourphi + &
+ (-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(21))* sinfourphi)* sinthetasq) +&
+ ((cij_kl(4) + 3.d0* cij_kl(9) - 4.d0* cij_kl(13) + cij_kl(20))* cosphi + &
+ 3.d0* (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi - &
+ (3.d0* cij_kl(5) + cij_kl(10) - 4.d0* cij_kl(14) + cij_kl(18))* sinphi + &
+ 3.d0* (-cij_kl(5) + cij_kl(10) + cij_kl(18))* sinthreephi)* sinthreetheta)
+
+ cij_kll(18) = 1.d0/2.d0* ((cij_kl(5) - cij_kl(10) + cij_kl(18))* cosphi* costwotheta - &
+ (cij_kl(5) - cij_kl(10) - cij_kl(18))* costhreephi* costwotheta - &
+ 2.d0* (cij_kl(4) - cij_kl(9) + &
+ (cij_kl(4) - cij_kl(9) + cij_kl(20))* costwophi)* costwotheta* sinphi + &
+ (cij_kl(1) - cij_kl(2) + cij_kl(7) - cij_kl(16) - cij_kl(19) + cij_kl(21) + &
+ (-cij_kl(16) + cij_kl(19))* costwophi + &
+ (-cij_kl(1) + cij_kl(2) - cij_kl(7) + cij_kl(21))* cosfourphi + &
+ cij_kl(17)* sintwophi + &
+ (-cij_kl(6) + cij_kl(11))* sinfourphi)* sintwotheta)
+
+ cij_kll(19) = 1.d0/4.d0* (cij_kl(16) - cij_kl(16)* costwophi + &
+ (-cij_kl(15) + cij_kl(17))* sintwophi + &
+ 4.d0* cij_kl(12)* sintwothetasq + &
+ 2.d0* (2.d0* cij_kl(1)* cosphifour* sintwothetasq + &
+ cosphi*cosphisq* (8.d0* cij_kl(6)* costhetasq* sinphi* sinthetasq + &
+ cij_kl(5)* sinfourtheta) + cosphisq* (-cij_kl(3) + cij_kl(19) + (cij_kl(3) +&
+ cij_kl(19))* cosfourtheta + (cij_kl(4) + cij_kl(20))* sinphi* sinfourtheta) + &
+ sinphi* (cosfourtheta* ((cij_kl(15) + cij_kl(17))* cosphi + &
+ cij_kl(16)* sinphi) + (cij_kl(2) + cij_kl(7) - 2.d0* cij_kl(8) + cij_kl(21) + &
+ (cij_kl(2) - cij_kl(7) + cij_kl(21))* costwophi)* sinphi* sintwothetasq + &
+ (-cij_kl(13) + cij_kl(9)* sinphisq)* sinfourtheta) + &
+ cosphi* (8.d0* cij_kl(11)* costhetasq* sinphi*sinphisq* sinthetasq + &
+ (-cij_kl(14) + (cij_kl(10) + cij_kl(18))* sinphisq)* sinfourtheta)))
+
+ cij_kll(20) = 1.d0/8.d0* (2.d0* cosphi* costheta* (-3.d0* cij_kl(4) - cij_kl(9) + &
+ 4.d0* cij_kl(13) + cij_kl(20) + (cij_kl(4) + 3.d0* cij_kl(9) - &
+ 4.d0* cij_kl(13) + cij_kl(20))* costwotheta) + &
+ (cij_kl(4) - cij_kl(9) + cij_kl(20))* costhreephi* (costheta + &
+ 3.d0* costhreetheta) - &
+ 2.d0* costheta* (-cij_kl(5) - 3.d0* cij_kl(10) + 4.d0* cij_kl(14) + &
+ cij_kl(18) + (3.d0* cij_kl(5) + &
+ cij_kl(10) - 4.d0* cij_kl(14) + cij_kl(18))*costwotheta)* sinphi - &
+ (cij_kl(5) - cij_kl(10) - cij_kl(18))* &
+ (costheta + 3.d0* costhreetheta)* sinthreephi + 8.d0* (cij_kl(6) - &
+ cij_kl(11))* cosfourphi* costhetasq* sintheta - 8.d0* (cij_kl(1) - &
+ cij_kl(3) - cij_kl(7) + cij_kl(8) + &
+ (cij_kl(1) - cij_kl(3) - cij_kl(7) + cij_kl(8) + cij_kl(16) - &
+ cij_kl(19))* costwotheta)* sintwophi* sintheta - &
+ 8.d0* (cij_kl(1) - cij_kl(2) + cij_kl(7) - &
+ cij_kl(21))* costhetasq* sinfourphi* sintheta + &
+ 2.d0* costwophi* ((cij_kl(6) + cij_kl(11) - 2.d0* cij_kl(15) + &
+ 2.d0* cij_kl(17))* sintheta + &
+ (cij_kl(6) + cij_kl(11) - 2.d0* (cij_kl(15) + cij_kl(17)))* sinthreetheta))
+
+ cij_kll(21) = 1.d0/4.d0* (cij_kl(1) - cij_kl(2) + cij_kl(7) + cij_kl(16) + &
+ cij_kl(19) + cij_kl(21) - 2.d0* (cij_kl(1) - cij_kl(2) + cij_kl(7) - &
+ cij_kl(21))* cosfourphi* costhetasq + &
+ (cij_kl(1) - cij_kl(2) + cij_kl(7) - cij_kl(16) - cij_kl(19) + &
+ cij_kl(21))* costwotheta + &
+ 2.d0* (-cij_kl(6) + cij_kl(11))* costhetasq* sinfourphi - &
+ 2.d0* ((-cij_kl(16) + cij_kl(19))* costwophi + cij_kl(17)* sintwophi)* sinthetasq - &
+ ((cij_kl(5) - cij_kl(10) + cij_kl(18))* cosphi + (-cij_kl(5) + cij_kl(10) +&
+ cij_kl(18))* costhreephi + &
+ (-cij_kl(4) + cij_kl(9) + cij_kl(20))* sinphi - (cij_kl(4) - cij_kl(9) + &
+ cij_kl(20))* sinthreephi)* sintwotheta)
+
+ end subroutine rotate_kernels_dble
+
+!-----------------------------------------------------------------------------
+
+ subroutine compute_kernels_hessian(ibool_crust_mantle, &
+ hess_kl_crust_mantle, &
+ accel_crust_mantle,b_accel_crust_mantle, &
+ deltat)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ hess_kl_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_accel_crust_mantle
+
+ real(kind=CUSTOM_REAL) deltat
+
+ ! local parameters
+ integer :: i,j,k,ispec,iglob
+
+ ! crust_mantle
+ do ispec = 1, NSPEC_CRUST_MANTLE
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+
+ ! approximates hessian
+ ! term with adjoint acceleration and backward/reconstructed acceleration
+ hess_kl_crust_mantle(i,j,k,ispec) = hess_kl_crust_mantle(i,j,k,ispec) &
+ + deltat * (accel_crust_mantle(1,iglob) * b_accel_crust_mantle(1,iglob) &
+ + accel_crust_mantle(2,iglob) * b_accel_crust_mantle(2,iglob) &
+ + accel_crust_mantle(3,iglob) * b_accel_crust_mantle(3,iglob) )
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+
+ end subroutine compute_kernels_hessian
+
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_seismograms.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_seismograms.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_seismograms.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_seismograms.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,377 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ implicit none
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer nrec_local,nrec
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ displ_crust_mantle
+
+ double precision, dimension(NDIM,NDIM,nrec) :: nu
+
+ double precision, dimension(nrec_local,NGLLX) :: hxir_store
+ double precision, dimension(nrec_local,NGLLY) :: hetar_store
+ double precision, dimension(nrec_local,NGLLZ) :: hgammar_store
+
+ double precision scale_displ
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ integer, dimension(nrec) :: ispec_selected_rec
+ integer, dimension(nrec_local) :: number_receiver_global
+
+ integer :: seismo_current
+ integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: &
+ seismograms
+
+ ! local parameters
+ double precision :: uxd,uyd,uzd,hlagrange
+ integer :: i,j,k,iglob,irec_local,irec
+
+ 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
+
+ end subroutine compute_seismograms
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ implicit none
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer nrec_local,nrec
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_displ_crust_mantle
+
+ double precision, dimension(NDIM,NDIM,nrec) :: nu
+
+ double precision, dimension(nrec_local,NGLLX) :: hxir_store
+ double precision, dimension(nrec_local,NGLLY) :: hetar_store
+ double precision, dimension(nrec_local,NGLLZ) :: hgammar_store
+
+ double precision scale_displ
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ integer, dimension(nrec) :: ispec_selected_rec
+ integer, dimension(nrec_local) :: number_receiver_global
+
+ integer :: seismo_current
+ integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: &
+ seismograms
+
+ ! local parameters
+ double precision :: uxd,uyd,uzd,hlagrange
+ integer :: i,j,k,iglob,irec_local,irec
+
+ 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(b_displ_crust_mantle(1,iglob))*hlagrange
+ uyd = uyd + dble(b_displ_crust_mantle(2,iglob))*hlagrange
+ uzd = uzd + dble(b_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
+
+ end subroutine compute_seismograms_backward
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
+ eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ hxir_store,hetar_store,hgammar_store, &
+ hpxir_store,hpetar_store,hpgammar_store, &
+ tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ moment_der,sloc_der,stshift_der,shdur_der,&
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
+ ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
+ NSTEP,it,nit_written)
+
+ implicit none
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer NSOURCES,nrec_local
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ displ_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
+ eps_trace_over_3_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
+ epsilondev_crust_mantle
+
+ double precision, dimension(NDIM,NDIM,NSOURCES) :: nu_source
+ double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+
+ double precision, dimension(nrec_local,NGLLX) :: hxir_store,hpxir_store
+ double precision, dimension(nrec_local,NGLLY) :: hetar_store,hpetar_store
+ double precision, dimension(nrec_local,NGLLZ) :: hgammar_store,hpgammar_store
+
+ double precision, dimension(NSOURCES) :: tshift_cmt,hdur_gaussian
+ double precision :: DT,t0
+ double precision :: scale_displ, scale_t
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
+ 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(NDIM,NDIM,nrec_local) :: moment_der
+ real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local) :: sloc_der
+ real(kind=CUSTOM_REAL), dimension(nrec_local) :: stshift_der, shdur_der
+
+ integer NTSTEP_BETWEEN_OUTPUT_SEISMOS
+
+ real(kind=CUSTOM_REAL), dimension(NDIM*NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: &
+ seismograms
+ real(kind=CUSTOM_REAL) :: deltat
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ integer,dimension(NSOURCES) :: ispec_selected_source
+ integer, dimension(nrec_local) :: number_receiver_global
+ integer :: NSTEP,it,nit_written
+
+ ! local parameters
+ double precision :: uxd,uyd,uzd,hlagrange
+ double precision :: eps_trace,dxx,dyy,dxy,dxz,dyz
+ double precision :: eps_loc(NDIM,NDIM), eps_loc_new(NDIM,NDIM)
+ double precision :: stf
+ real(kind=CUSTOM_REAL) :: displ_s(NDIM,NGLLX,NGLLY,NGLLZ)
+ real(kind=CUSTOM_REAL) :: eps_s(NDIM,NDIM), eps_m_s, &
+ eps_m_l_s(NDIM), stf_deltat, Kp_deltat, Hp_deltat
+ integer :: i,j,k,iglob,irec_local,irec,ispec
+
+ double precision, external :: comp_source_time_function
+
+ 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
+
+
+ eps_trace = ZERO
+ dxx = ZERO
+ dyy = ZERO
+ dxy = ZERO
+ dxz = ZERO
+ dyz = ZERO
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ iglob = ibool_crust_mantle(i,j,k,ispec_selected_source(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
+
+ eps_trace = eps_trace + dble(eps_trace_over_3_crust_mantle(i,j,k,ispec_selected_source(irec)))*hlagrange
+ dxx = dxx + dble(epsilondev_crust_mantle(1,i,j,k,ispec_selected_source(irec)))*hlagrange
+ dyy = dyy + dble(epsilondev_crust_mantle(2,i,j,k,ispec_selected_source(irec)))*hlagrange
+ dxy = dxy + dble(epsilondev_crust_mantle(3,i,j,k,ispec_selected_source(irec)))*hlagrange
+ dxz = dxz + dble(epsilondev_crust_mantle(4,i,j,k,ispec_selected_source(irec)))*hlagrange
+ dyz = dyz + dble(epsilondev_crust_mantle(5,i,j,k,ispec_selected_source(irec)))*hlagrange
+
+ displ_s(:,i,j,k) = displ_crust_mantle(:,iglob)
+
+ enddo
+ enddo
+ enddo
+
+ eps_loc(1,1) = eps_trace + dxx
+ eps_loc(2,2) = eps_trace + dyy
+ eps_loc(3,3) = eps_trace - dxx - dyy
+ eps_loc(1,2) = dxy
+ eps_loc(1,3) = dxz
+ eps_loc(2,3) = dyz
+ eps_loc(2,1) = dxy
+ eps_loc(3,1) = dxz
+ eps_loc(3,2) = dyz
+
+ eps_loc_new(:,:) = eps_loc(:,:)
+ ! rotate to the local cartesian coordinates (n-e-z): eps_new=P*eps*P'
+ eps_loc_new(:,:) = matmul(matmul(nu_source(:,:,irec),eps_loc(:,:)), transpose(nu_source(:,:,irec)))
+
+ ! distinguish between single and double precision for reals
+ if (CUSTOM_REAL == SIZE_REAL) then
+ seismograms(1,irec_local,it-nit_written) = sngl(eps_loc_new(1,1))
+ seismograms(2,irec_local,it-nit_written) = sngl(eps_loc_new(2,2))
+ seismograms(3,irec_local,it-nit_written) = sngl(eps_loc_new(3,3))
+ seismograms(4,irec_local,it-nit_written) = sngl(eps_loc_new(1,2))
+ seismograms(5,irec_local,it-nit_written) = sngl(eps_loc_new(1,3))
+ seismograms(6,irec_local,it-nit_written) = sngl(eps_loc_new(2,3))
+ seismograms(7:9,irec_local,it-nit_written) = sngl(scale_displ*(nu_source(:,1,irec)*uxd + &
+ nu_source(:,2,irec)*uyd + nu_source(:,3,irec)*uzd))
+ else
+ seismograms(1,irec_local,it-nit_written) = eps_loc_new(1,1)
+ seismograms(2,irec_local,it-nit_written) = eps_loc_new(2,2)
+ seismograms(3,irec_local,it-nit_written) = eps_loc_new(3,3)
+ seismograms(4,irec_local,it-nit_written) = eps_loc_new(1,2)
+ seismograms(5,irec_local,it-nit_written) = eps_loc_new(1,3)
+ seismograms(6,irec_local,it-nit_written) = eps_loc_new(2,3)
+ seismograms(7:9,irec_local,it-nit_written) = scale_displ*(nu_source(:,1,irec)*uxd + &
+ nu_source(:,2,irec)*uyd + nu_source(:,3,irec)*uzd)
+ endif
+
+ ! frechet derviatives of the source
+ ispec = ispec_selected_source(irec)
+
+ call compute_adj_source_frechet(displ_s,Mxx(irec),Myy(irec),Mzz(irec), &
+ Mxy(irec),Mxz(irec),Myz(irec),eps_s,eps_m_s,eps_m_l_s, &
+ hxir_store(irec_local,:),hetar_store(irec_local,:),hgammar_store(irec_local,:), &
+ hpxir_store(irec_local,:),hpetar_store(irec_local,:),hpgammar_store(irec_local,:), &
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix_crust_mantle(:,:,:,ispec),xiy_crust_mantle(:,:,:,ispec),xiz_crust_mantle(:,:,:,ispec), &
+ etax_crust_mantle(:,:,:,ispec),etay_crust_mantle(:,:,:,ispec),etaz_crust_mantle(:,:,:,ispec), &
+ gammax_crust_mantle(:,:,:,ispec),gammay_crust_mantle(:,:,:,ispec),gammaz_crust_mantle(:,:,:,ispec))
+
+ stf = comp_source_time_function(dble(NSTEP-it)*DT-t0-tshift_cmt(irec),hdur_gaussian(irec))
+ stf_deltat = stf * deltat
+
+ moment_der(:,:,irec_local) = moment_der(:,:,irec_local) + eps_s(:,:) * stf_deltat
+ sloc_der(:,irec_local) = sloc_der(:,irec_local) + eps_m_l_s(:) * stf_deltat
+
+ scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
+ Kp_deltat= -1.0d0/sqrt(PI)/hdur_gaussian(irec)*exp(-((dble(NSTEP-it)*DT-t0-tshift_cmt(irec))/hdur_gaussian(irec))**2) &
+ * deltat * scale_t
+ Hp_deltat= (dble(NSTEP-it)*DT-t0-tshift_cmt(irec))/hdur_gaussian(irec)*Kp_deltat
+
+ stshift_der(irec_local) = stshift_der(irec_local) + eps_m_s * Kp_deltat
+
+ shdur_der(irec_local) = shdur_der(irec_local) + eps_m_s * Hp_deltat
+
+
+ enddo
+
+ end subroutine compute_seismograms_adjoint
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_stacey_crust_mantle.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_crust_mantle.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_stacey_crust_mantle.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_stacey_crust_mantle.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,354 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_stacey_crust_mantle(ichunk,SIMULATION_TYPE, &
+ NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
+ veloc_crust_mantle,accel_crust_mantle,b_accel_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+ wgllwgll_xz,wgllwgll_yz, &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+ normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+ rho_vp_crust_mantle,rho_vs_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+ ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ nimin_crust_mantle,nimax_crust_mantle, &
+ njmin_crust_mantle,njmax_crust_mantle, &
+ nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle,absorb_xmax_crust_mantle, &
+ absorb_ymin_crust_mantle,absorb_ymax_crust_mantle)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer ichunk,SIMULATION_TYPE
+ integer NSTEP,it
+ logical SAVE_FORWARD
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ veloc_crust_mantle,accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_accel_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
+ 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,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ 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(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: &
+ rho_vp_crust_mantle,rho_vs_crust_mantle
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
+
+ integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_CM) :: &
+ nimin_crust_mantle,nimax_crust_mantle,nkmin_eta_crust_mantle
+ integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_CM) :: &
+ njmin_crust_mantle,njmax_crust_mantle,nkmin_xi_crust_mantle
+
+ integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
+
+ integer reclen_xmin_crust_mantle,reclen_xmax_crust_mantle,&
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle
+
+ integer nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nabs_xmin_cm) :: absorb_xmin_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nabs_xmax_cm) :: absorb_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nabs_ymin_cm) :: absorb_ymin_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nabs_ymax_cm) :: absorb_ymax_crust_mantle
+
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: weight
+ real(kind=CUSTOM_REAL) :: vn,vx,vy,vz,nx,ny,nz,tx,ty,tz
+ integer :: i,j,k,ispec,iglob,ispec2D
+ !integer :: reclen1,reclen2
+
+ ! note: we use c functions for I/O as they still have a better performance than
+ ! fortran, unformatted file I/O. however, using -assume byterecl together with fortran functions
+ ! comes very close (only ~ 4 % slower ).
+ !
+ ! tests with intermediate storages (every 8 step) and/or asynchronious
+ ! file access (by process rank modulo 8) showed that the following,
+ ! simple approach is still fastest. (assuming that files are accessed on a local scratch disk)
+
+
+ ! crust & mantle
+
+ ! xmin
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
+
+ ! reads absorbing boundary values
+ if (SIMULATION_TYPE == 3 .and. nspec2D_xmin_crust_mantle > 0) then
+ ! note: backward/reconstructed wavefields are read in after the Newmark time scheme in the first time loop
+ ! this leads to a corresponding boundary condition at time index NSTEP - (it-1) = NSTEP - it + 1
+ call read_abs(0,absorb_xmin_crust_mantle,reclen_xmin_crust_mantle,NSTEP-it+1)
+ endif
+
+ do ispec2D=1,nspec2D_xmin_crust_mantle
+
+ ispec=ibelm_xmin_crust_mantle(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi_crust_mantle(1,ispec2D) == 0 .or. njmin_crust_mantle(1,ispec2D) == 0) cycle
+
+ i=1
+ do k=nkmin_xi_crust_mantle(1,ispec2D),NGLLZ
+ do j=njmin_crust_mantle(1,ispec2D),njmax_crust_mantle(1,ispec2D)
+ iglob=ibool_crust_mantle(i,j,k,ispec)
+
+ vx=veloc_crust_mantle(1,iglob)
+ vy=veloc_crust_mantle(2,iglob)
+ vz=veloc_crust_mantle(3,iglob)
+
+ nx=normal_xmin_crust_mantle(1,j,k,ispec2D)
+ ny=normal_xmin_crust_mantle(2,j,k,ispec2D)
+ nz=normal_xmin_crust_mantle(3,j,k,ispec2D)
+
+ vn=vx*nx+vy*ny+vz*nz
+
+ tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
+ ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
+ tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
+
+ weight=jacobian2D_xmin_crust_mantle(j,k,ispec2D)*wgllwgll_yz(j,k)
+
+ accel_crust_mantle(1,iglob)=accel_crust_mantle(1,iglob) - tx*weight
+ accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
+ accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
+
+ if (SIMULATION_TYPE == 3) then
+ b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_xmin_crust_mantle(:,j,k,ispec2D)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ absorb_xmin_crust_mantle(1,j,k,ispec2D) = tx*weight
+ absorb_xmin_crust_mantle(2,j,k,ispec2D) = ty*weight
+ absorb_xmin_crust_mantle(3,j,k,ispec2D) = tz*weight
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! writes absorbing boundary values
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmin_crust_mantle > 0 ) then
+ call write_abs(0,absorb_xmin_crust_mantle, reclen_xmin_crust_mantle,it)
+ endif
+ endif
+
+ ! xmax
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB) then
+
+ ! reads absorbing boundary values
+ if (SIMULATION_TYPE == 3 .and. nspec2D_xmax_crust_mantle > 0) then
+ call read_abs(1,absorb_xmax_crust_mantle,reclen_xmax_crust_mantle,NSTEP-it+1)
+ endif
+
+ do ispec2D=1,nspec2D_xmax_crust_mantle
+
+ ispec=ibelm_xmax_crust_mantle(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi_crust_mantle(2,ispec2D) == 0 .or. njmin_crust_mantle(2,ispec2D) == 0) cycle
+
+ i=NGLLX
+ do k=nkmin_xi_crust_mantle(2,ispec2D),NGLLZ
+ do j=njmin_crust_mantle(2,ispec2D),njmax_crust_mantle(2,ispec2D)
+ iglob=ibool_crust_mantle(i,j,k,ispec)
+
+ vx=veloc_crust_mantle(1,iglob)
+ vy=veloc_crust_mantle(2,iglob)
+ vz=veloc_crust_mantle(3,iglob)
+
+ nx=normal_xmax_crust_mantle(1,j,k,ispec2D)
+ ny=normal_xmax_crust_mantle(2,j,k,ispec2D)
+ nz=normal_xmax_crust_mantle(3,j,k,ispec2D)
+
+ vn=vx*nx+vy*ny+vz*nz
+
+ tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
+ ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
+ tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
+
+ weight=jacobian2D_xmax_crust_mantle(j,k,ispec2D)*wgllwgll_yz(j,k)
+
+ accel_crust_mantle(1,iglob)=accel_crust_mantle(1,iglob) - tx*weight
+ accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
+ accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
+
+ if (SIMULATION_TYPE == 3) then
+ b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_xmax_crust_mantle(:,j,k,ispec2D)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ absorb_xmax_crust_mantle(1,j,k,ispec2D) = tx*weight
+ absorb_xmax_crust_mantle(2,j,k,ispec2D) = ty*weight
+ absorb_xmax_crust_mantle(3,j,k,ispec2D) = tz*weight
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ! writes absorbing boundary values
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmax_crust_mantle > 0 ) then
+ call write_abs(1,absorb_xmax_crust_mantle,reclen_xmax_crust_mantle,it)
+ endif
+ endif
+
+ ! ymin
+
+ ! reads absorbing boundary values
+ if (SIMULATION_TYPE == 3 .and. nspec2D_ymin_crust_mantle > 0) then
+ call read_abs(2,absorb_ymin_crust_mantle, reclen_ymin_crust_mantle,NSTEP-it+1)
+ endif
+
+ do ispec2D=1,nspec2D_ymin_crust_mantle
+
+ ispec=ibelm_ymin_crust_mantle(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta_crust_mantle(1,ispec2D) == 0 .or. nimin_crust_mantle(1,ispec2D) == 0) cycle
+
+ j=1
+ do k=nkmin_eta_crust_mantle(1,ispec2D),NGLLZ
+ do i=nimin_crust_mantle(1,ispec2D),nimax_crust_mantle(1,ispec2D)
+ iglob=ibool_crust_mantle(i,j,k,ispec)
+
+ vx=veloc_crust_mantle(1,iglob)
+ vy=veloc_crust_mantle(2,iglob)
+ vz=veloc_crust_mantle(3,iglob)
+
+ nx=normal_ymin_crust_mantle(1,i,k,ispec2D)
+ ny=normal_ymin_crust_mantle(2,i,k,ispec2D)
+ nz=normal_ymin_crust_mantle(3,i,k,ispec2D)
+
+ vn=vx*nx+vy*ny+vz*nz
+
+ tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
+ ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
+ tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
+
+ weight=jacobian2D_ymin_crust_mantle(i,k,ispec2D)*wgllwgll_xz(i,k)
+
+ accel_crust_mantle(1,iglob)=accel_crust_mantle(1,iglob) - tx*weight
+ accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
+ accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
+
+ if (SIMULATION_TYPE == 3) then
+ b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_ymin_crust_mantle(:,i,k,ispec2D)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ absorb_ymin_crust_mantle(1,i,k,ispec2D) = tx*weight
+ absorb_ymin_crust_mantle(2,i,k,ispec2D) = ty*weight
+ absorb_ymin_crust_mantle(3,i,k,ispec2D) = tz*weight
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ! writes absorbing boundary values
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymin_crust_mantle > 0 ) then
+ call write_abs(2,absorb_ymin_crust_mantle,reclen_ymin_crust_mantle,it)
+ endif
+
+
+
+ ! ymax
+
+ ! reads absorbing boundary values
+ if (SIMULATION_TYPE == 3 .and. nspec2D_ymax_crust_mantle > 0) then
+ call read_abs(3,absorb_ymax_crust_mantle,reclen_ymax_crust_mantle,NSTEP-it+1)
+ endif
+
+ do ispec2D=1,nspec2D_ymax_crust_mantle
+
+ ispec=ibelm_ymax_crust_mantle(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta_crust_mantle(2,ispec2D) == 0 .or. nimin_crust_mantle(2,ispec2D) == 0) cycle
+
+ j=NGLLY
+ do k=nkmin_eta_crust_mantle(2,ispec2D),NGLLZ
+ do i=nimin_crust_mantle(2,ispec2D),nimax_crust_mantle(2,ispec2D)
+ iglob=ibool_crust_mantle(i,j,k,ispec)
+
+ vx=veloc_crust_mantle(1,iglob)
+ vy=veloc_crust_mantle(2,iglob)
+ vz=veloc_crust_mantle(3,iglob)
+
+ nx=normal_ymax_crust_mantle(1,i,k,ispec2D)
+ ny=normal_ymax_crust_mantle(2,i,k,ispec2D)
+ nz=normal_ymax_crust_mantle(3,i,k,ispec2D)
+
+ vn=vx*nx+vy*ny+vz*nz
+
+ tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
+ ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
+ tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
+
+ weight=jacobian2D_ymax_crust_mantle(i,k,ispec2D)*wgllwgll_xz(i,k)
+
+ accel_crust_mantle(1,iglob)=accel_crust_mantle(1,iglob) - tx*weight
+ accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
+ accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
+
+ if (SIMULATION_TYPE == 3) then
+ b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_ymax_crust_mantle(:,i,k,ispec2D)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ absorb_ymax_crust_mantle(1,i,k,ispec2D) = tx*weight
+ absorb_ymax_crust_mantle(2,i,k,ispec2D) = ty*weight
+ absorb_ymax_crust_mantle(3,i,k,ispec2D) = tz*weight
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ! writes absorbing boundary values
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymax_crust_mantle > 0 ) then
+ call write_abs(3,absorb_ymax_crust_mantle,reclen_ymax_crust_mantle,it)
+ endif
+
+ end subroutine compute_stacey_crust_mantle
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_stacey_outer_core.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_outer_core.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_stacey_outer_core.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_stacey_outer_core.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
+ NSTEP,it,ibool_outer_core, &
+ veloc_outer_core,accel_outer_core,b_accel_outer_core, &
+ vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+ jacobian2D_bottom_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer ichunk,SIMULATION_TYPE
+ integer NSTEP,it
+ logical SAVE_FORWARD
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
+ veloc_outer_core,accel_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
+ b_accel_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_STACEY) :: vp_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ 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,NSPEC2D_BOTTOM_OC) :: &
+ jacobian2D_bottom_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
+
+
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
+
+ integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_OC) :: &
+ nimin_outer_core,nimax_outer_core,nkmin_eta_outer_core
+ integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_OC) :: &
+ njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_BOTTOM
+ integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
+
+ integer reclen_zmin,reclen_xmin_outer_core,reclen_xmax_outer_core,&
+ reclen_ymin_outer_core,reclen_ymax_outer_core
+
+ integer nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc,nabs_zmin_oc
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nabs_xmin_oc) :: absorb_xmin_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nabs_xmax_oc) :: absorb_xmax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nabs_ymin_oc) :: absorb_ymin_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nabs_ymax_oc) :: absorb_ymax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,nabs_zmin_oc) :: absorb_zmin_outer_core
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: sn,weight
+ !integer :: reclen1,reclen2
+ integer :: i,j,k,ispec2D,ispec,iglob
+
+ ! note: we use c functions for I/O as they still have a better performance than
+ ! fortran, unformatted file I/O. however, using -assume byterecl together with fortran functions
+ ! comes very close (only ~ 4 % slower ).
+ !
+ ! tests with intermediate storages (every 8 step) and/or asynchronious
+ ! file access (by process rank modulo 8) showed that the following,
+ ! simple approach is still fastest. (assuming that files are accessed on a local scratch disk)
+
+ ! xmin
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
+
+ ! reads absorbing boundary values
+ if (SIMULATION_TYPE == 3 .and. nspec2D_xmin_outer_core > 0) then
+ ! note: backward/reconstructed wavefields are read in after the Newmark time scheme in the first time loop
+ ! this leads to a corresponding boundary condition at time index NSTEP - (it-1) = NSTEP - it + 1
+
+ call read_abs(4,absorb_xmin_outer_core,reclen_xmin_outer_core,NSTEP-it+1)
+
+! read(61,rec=NSTEP-it+1) reclen1,absorb_xmin_outer_core,reclen2
+! if (reclen1 /= reclen_xmin_outer_core .or. reclen1 /= reclen2) &
+! call exit_MPI(myrank,'Error reading absorbing contribution absorb_xmin_outer_core')
+
+
+ endif
+
+ do ispec2D=1,nspec2D_xmin_outer_core
+
+ ispec=ibelm_xmin_outer_core(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi_outer_core(1,ispec2D) == 0 .or. njmin_outer_core(1,ispec2D) == 0) cycle
+
+ i=1
+ do k=nkmin_xi_outer_core(1,ispec2D),NGLLZ
+ do j=njmin_outer_core(1,ispec2D),njmax_outer_core(1,ispec2D)
+ iglob=ibool_outer_core(i,j,k,ispec)
+
+ sn = veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
+
+ weight = jacobian2D_xmin_outer_core(j,k,ispec2D)*wgllwgll_yz(j,k)
+
+ accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
+
+ if (SIMULATION_TYPE == 3) then
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_xmin_outer_core(j,k,ispec2D)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ absorb_xmin_outer_core(j,k,ispec2D) = weight*sn
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! writes absorbing boundary values
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmin_outer_core > 0 ) then
+
+ call write_abs(4,absorb_xmin_outer_core,reclen_xmin_outer_core,it)
+
+! write(61,rec=it) reclen_xmin_outer_core,absorb_xmin_outer_core,reclen_xmin_outer_core
+ endif
+
+ endif
+
+ ! xmax
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB) then
+
+ if (SIMULATION_TYPE == 3 .and. nspec2D_xmax_outer_core > 0) then
+
+ call read_abs(5,absorb_xmax_outer_core,reclen_xmax_outer_core,NSTEP-it+1)
+
+! read(62,rec=NSTEP-it+1) reclen1,absorb_xmax_outer_core,reclen2
+! if (reclen1 /= reclen_xmax_outer_core .or. reclen1 /= reclen2) &
+! call exit_MPI(myrank,'Error reading absorbing contribution absorb_xmax_outer_core')
+ endif
+
+ do ispec2D=1,nspec2D_xmax_outer_core
+
+ ispec=ibelm_xmax_outer_core(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi_outer_core(2,ispec2D) == 0 .or. njmin_outer_core(2,ispec2D) == 0) cycle
+
+ i=NGLLX
+ do k=nkmin_xi_outer_core(2,ispec2D),NGLLZ
+ do j=njmin_outer_core(2,ispec2D),njmax_outer_core(2,ispec2D)
+ iglob=ibool_outer_core(i,j,k,ispec)
+
+ sn = veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
+
+ weight = jacobian2D_xmax_outer_core(j,k,ispec2D)*wgllwgll_yz(j,k)
+
+ accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
+
+ if (SIMULATION_TYPE == 3) then
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_xmax_outer_core(j,k,ispec2D)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ absorb_xmax_outer_core(j,k,ispec2D) = weight*sn
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmax_outer_core > 0 ) then
+ call write_abs(5,absorb_xmax_outer_core,reclen_xmax_outer_core,it)
+
+! write(62,rec=it) reclen_xmax_outer_core,absorb_xmax_outer_core,reclen_xmax_outer_core
+ endif
+
+ endif
+
+ ! ymin
+ if (SIMULATION_TYPE == 3 .and. nspec2D_ymin_outer_core > 0) then
+
+ call read_abs(6,absorb_ymin_outer_core,reclen_ymin_outer_core,NSTEP-it+1)
+
+! read(63,rec=NSTEP-it+1) reclen1,absorb_ymin_outer_core,reclen2
+! if (reclen1 /= reclen_ymin_outer_core .or. reclen1 /= reclen2) &
+! call exit_MPI(myrank,'Error reading absorbing contribution absorb_ymin_outer_core')
+ endif
+
+ do ispec2D=1,nspec2D_ymin_outer_core
+
+ ispec=ibelm_ymin_outer_core(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta_outer_core(1,ispec2D) == 0 .or. nimin_outer_core(1,ispec2D) == 0) cycle
+
+ j=1
+ do k=nkmin_eta_outer_core(1,ispec2D),NGLLZ
+ do i=nimin_outer_core(1,ispec2D),nimax_outer_core(1,ispec2D)
+ iglob=ibool_outer_core(i,j,k,ispec)
+
+ sn = veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
+
+ weight=jacobian2D_ymin_outer_core(i,k,ispec2D)*wgllwgll_xz(i,k)
+
+ accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
+
+ if (SIMULATION_TYPE == 3) then
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_ymin_outer_core(i,k,ispec2D)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ absorb_ymin_outer_core(i,k,ispec2D) = weight*sn
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymin_outer_core > 0 ) then
+ call write_abs(6,absorb_ymin_outer_core,reclen_ymin_outer_core,it)
+
+! write(63,rec=it) reclen_ymin_outer_core,absorb_ymin_outer_core,reclen_ymin_outer_core
+ endif
+
+ ! ymax
+ if (SIMULATION_TYPE == 3 .and. nspec2D_ymax_outer_core > 0) then
+
+ call read_abs(7,absorb_ymax_outer_core,reclen_ymax_outer_core,NSTEP-it+1)
+
+! read(64,rec=NSTEP-it+1) reclen1,absorb_ymax_outer_core,reclen2
+! if (reclen1 /= reclen_ymax_outer_core .or. reclen1 /= reclen2) &
+! call exit_MPI(myrank,'Error reading absorbing contribution absorb_ymax_outer_core')
+ endif
+ do ispec2D=1,nspec2D_ymax_outer_core
+
+ ispec=ibelm_ymax_outer_core(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta_outer_core(2,ispec2D) == 0 .or. nimin_outer_core(2,ispec2D) == 0) cycle
+
+ j=NGLLY
+ do k=nkmin_eta_outer_core(2,ispec2D),NGLLZ
+ do i=nimin_outer_core(2,ispec2D),nimax_outer_core(2,ispec2D)
+ iglob=ibool_outer_core(i,j,k,ispec)
+
+ sn = veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
+
+ weight=jacobian2D_ymax_outer_core(i,k,ispec2D)*wgllwgll_xz(i,k)
+
+ accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
+
+ if (SIMULATION_TYPE == 3) then
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_ymax_outer_core(i,k,ispec2D)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ absorb_ymax_outer_core(i,k,ispec2D) = weight*sn
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymax_outer_core > 0 ) then
+ call write_abs(7,absorb_ymax_outer_core,reclen_ymax_outer_core,it)
+
+! write(64,rec=it) reclen_ymax_outer_core,absorb_ymax_outer_core,reclen_ymax_outer_core
+ endif
+
+ ! for surface elements exactly on the ICB
+ if (SIMULATION_TYPE == 3 .and. NSPEC2D_BOTTOM(IREGION_OUTER_CORE)> 0) then
+
+ call read_abs(8,absorb_zmin_outer_core,reclen_zmin,NSTEP-it+1)
+
+! read(65,rec=NSTEP-it+1) reclen1,absorb_zmin_outer_core,reclen2
+! if (reclen1 /= reclen_zmin .or. reclen1 /= reclen2) &
+! call exit_MPI(myrank,'Error reading absorbing contribution absorb_zmin_outer_core')
+ endif
+
+ do ispec2D = 1,NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
+
+ ispec = ibelm_bottom_outer_core(ispec2D)
+
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool_outer_core(i,j,k,ispec)
+
+ sn = veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
+
+ weight = jacobian2D_bottom_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
+
+ if (SIMULATION_TYPE == 3) then
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_zmin_outer_core(i,j,ispec2D)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ absorb_zmin_outer_core(i,j,ispec2D) = weight*sn
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 ) then
+ call write_abs(8,absorb_zmin_outer_core,reclen_zmin,it)
+
+! write(65,rec=it) reclen_zmin,absorb_zmin_outer_core,reclen_zmin
+ endif
+
+ end subroutine compute_stacey_outer_core
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/convert_time.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/convert_time.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/convert_time.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/convert_time.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,235 @@
+
+! open-source subroutines taken from the World Ocean Circulation Experiment (WOCE)
+! web site at http://www.coaps.fsu.edu/woce/html/wcdtools.htm
+
+! converted to Fortran90 by Dimitri Komatitsch,
+! University of Pau, France, January 2008.
+! Also converted "convtime" from a function to a subroutine.
+! Also used a more complete test to detect leap years (the original version was incomplete).
+
+ subroutine convtime(timestamp,yr,mon,day,hr,min)
+
+! Originally written by Shawn Smith (smith AT coaps.fsu.edu)
+! Updated Spring 1999 for Y2K compliance by Anthony Arguez (anthony AT coaps.fsu.edu).
+
+! This subroutine will convert a given year, month, day, hour, and
+! minutes to a minutes from 01 Jan 1980 00:00 time stamp.
+
+ implicit none
+
+ integer, intent(out) :: timestamp
+
+ integer, intent(in) :: yr,mon,day,hr,min
+
+ integer :: year(1980:2020),month(12),leap_mon(12)
+
+ integer :: min_day,min_hr
+
+! function to determine if year is a leap year
+ logical, external :: is_leap_year
+
+ data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
+ 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
+ 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
+ 9993600, 10519200, 11046240, 11571840, 12097440, &
+ 12623040, 13150080, 13675680, 14201280, 14726880, &
+ 15253920, 15779520, 16305120, 16830720, 17357760, &
+ 17883360, 18408960, 18934560, 19461600, 19987200, &
+ 20512800, 21038400/
+
+ data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
+ 305280, 349920, 393120, 437760, 480960/
+
+ data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
+ 306720, 351360, 394560, 439200, 482400/
+
+ data min_day, min_hr /1440, 60/
+
+! Test values to see if they fit valid ranges
+ if (yr < 1980 .or. yr > 2020) stop 'Error in convtime: year out of range (1980-2020)'
+
+ if (mon < 1 .or. mon > 12) stop 'Error in convtime: month out of range (1-12)'
+
+ if (mon == 2) then
+ if (is_leap_year(yr) .and. (day < 1 .or. day > 29)) then
+ stop 'Error in convtime: February day out of range (1-29)'
+ elseif (.not. is_leap_year(yr) .and. (day < 1 .or. day > 28)) then
+ stop 'Error in convtime: February day out of range (1-28)'
+ endif
+ elseif (mon == 4 .or. mon == 6 .or. mon == 9 .or. mon == 11) then
+ if (day < 1 .or. day > 30) stop 'Error in convtime: day out of range (1-30)'
+ else
+ if (day < 1 .or. day > 31) stop 'Error in convtime: day out of range (1-31)'
+ endif
+
+ if (hr < 0 .or. hr > 23) stop 'Error in convtime: hour out of range (0-23)'
+
+ if (min < 0 .or. min > 60) stop 'Error in convtime: minute out of range (0-60)'
+
+! convert time (test if leap year)
+ if (is_leap_year(yr)) then
+ timestamp = year(yr)+leap_mon(mon)+((day-1)*min_day)+(hr*min_hr)+min
+ else
+ timestamp = year(yr)+month(mon)+((day-1)*min_day)+(hr*min_hr)+min
+ endif
+
+ end subroutine convtime
+
+!
+!----
+!
+
+ subroutine invtime(timestamp,yr,mon,day,hr,min)
+
+! This subroutine will convert a minutes timestamp to a year/month
+! date. Based on the function convtime by Shawn Smith (COAPS).
+!
+! Written the spring of 1995, several iterations.
+! James N. Stricherz (stricherz AT coaps.fsu.edu)
+!
+! Updated for Y2K compliance in July 1999.
+! Shyam Lakshmin (lakshmin AT coaps.fsu.edu)
+!
+! This code returns correct results for the range of 01 Jan 1980 00:00
+! thru 31 Dec 2020 23:59. I know it does, because I tried each minute of that range.
+
+ implicit none
+
+ integer, intent(in) :: timestamp
+
+ integer, intent(out) :: yr,mon,day,hr,min
+
+ integer :: year(1980:2021),month(13),leap_mon(13)
+
+ integer :: min_day,min_hr,itime,tmon,ttime,thour,iyr,imon,iday,ihour
+
+! function to determine if year is a leap year
+ logical, external :: is_leap_year
+
+ data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
+ 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
+ 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
+ 9993600, 10519200, 11046240, 11571840, 12097440, &
+ 12623040, 13150080, 13675680, 14201280, 14726880, &
+ 15253920, 15779520, 16305120, 16830720, 17357760, &
+ 17883360, 18408960, 18934560, 19461600, 19987200, &
+ 20512800, 21038400, 21565440/
+
+ data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
+ 305280, 349920, 393120, 437760, 480960,525600/
+
+ data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
+ 306720, 351360, 394560, 439200, 482400,527040/
+
+ data min_day, min_hr /1440, 60/
+
+! ok, let us invert the effects of the years: subtract off the
+! number of minutes per year until it goes negative
+! iyr then gives the year that the time (in minutes) occurs
+ if (timestamp >= year(2021)) stop 'year too high in invtime'
+
+ iyr=1979
+ itime=timestamp
+
+ 10 iyr=iyr+1
+ ttime=itime-year(iyr)
+ if (ttime <= 0) then
+ if (iyr == 1980) iyr=iyr+1
+ iyr=iyr-1
+ itime=itime-year(iyr)
+ else
+ goto 10
+ endif
+
+! assign the return variable
+ yr=iyr
+
+! ok, the remaining time is less than one full year, so convert
+! by the same method as above into months
+ imon=0
+
+! if not leap year
+ if (.not. is_leap_year(iyr)) then
+
+! increment the month, and subtract off the minutes from the
+! remaining time for a non-leap year
+ 20 imon=imon+1
+ tmon=itime-month(imon)
+ if (tmon > 0) then
+ goto 20
+ else if (tmon < 0) then
+ imon=imon-1
+ itime=itime-month(imon)
+ else
+ if (imon > 12) then
+ imon=imon-12
+ yr=yr+1
+ endif
+ mon=imon
+ day=1
+ hr=0
+ min=0
+ return
+ endif
+
+! if leap year
+ else
+
+! same thing, same code, but for a leap year
+ 30 imon=imon+1
+ tmon=itime-leap_mon(imon)
+ if (tmon > 0) then
+ goto 30
+ elseif (tmon < 0) then
+ imon=imon-1
+ itime=itime-month(imon)
+ else
+ if (imon > 12) then
+ imon=imon-12
+ yr=yr+1
+ endif
+ mon=imon
+ day=1
+ hr=0
+ min=0
+ return
+ endif
+ endif
+
+! assign the return variable
+ mon=imon
+
+! any remaining minutes will belong to day/hour/minutes
+! ok, let us get the days
+ iday=0
+ 40 iday=iday+1
+ ttime=itime-min_day
+ if (ttime >= 0) then
+ itime=ttime
+ goto 40
+ endif
+
+! assign the return variable
+ if (is_leap_year(iyr) .and. mon > 2) then
+ day=iday-1
+ else
+ day=iday
+ endif
+
+! pick off the hours of the days...remember, hours can be 0, so we start at -1
+ ihour=-1
+ 50 ihour=ihour+1
+ thour=itime-min_hr
+ if (thour >= 0) then
+ itime=thour
+ goto 50
+ endif
+
+! assign the return variables
+ hr=ihour
+
+! the remainder at this point is the minutes, so return them directly
+ min=itime
+
+ end subroutine invtime
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/convolve_source_timefunction.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/convolve_source_timefunction.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/convolve_source_timefunction.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/convolve_source_timefunction.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ 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/src/count_number_of_sources.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/count_number_of_sources.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/count_number_of_sources.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/count_number_of_sources.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/create_central_cube.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_central_cube.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_central_cube.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,275 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_central_cube(myrank,ichunk,ispec,iaddx,iaddy,iaddz, &
+ nspec,NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,R_CENTRAL_CUBE, &
+ iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,ratio_divide_central_cube, &
+ iMPIcut_xi,iMPIcut_eta,iboun, &
+ idoubling,iregion_code,xstore,ystore,zstore, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME,&
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ shape3D,rmin,rmax,rhostore,dvpstore,&
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore,nspec_actually, &
+ 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
+ rho_vp,rho_vs,ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS,xigll,yigll,zigll)
+
+! creates the inner core cube of the mesh
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer :: ratio_divide_central_cube
+
+! correct number of spectral elements in each block depending on chunk type
+ integer nspec,nspec_stacey
+
+ integer NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
+
+ integer NPROC_XI,NPROC_ETA
+
+ double precision R_CENTRAL_CUBE,RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,&
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,RMOHO_FICTITIOUS_IN_MESHER
+
+! 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)
+
+! 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 xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
+
+! 3D shape functions and their derivatives
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ integer idoubling(nspec)
+
+! for model density and anisotropy
+ integer nspec_ani
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
+
+! 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
+
+! boundary locator
+ logical iboun(6,nspec)
+
+! arrays with mesh parameters
+ integer nspec_actually
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+! proc numbers for MPI
+ integer myrank
+
+
+! MPI cut-planes parameters along xi and along eta
+ logical, dimension(2,nspec) :: iMPIcut_xi,iMPIcut_eta
+
+! Stacey, indices for Clayton-Engquist absorbing conditions
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
+
+ integer ispec
+ integer iproc_xi,iproc_eta,ichunk
+
+! attenuation
+ integer nspec_att
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
+ double precision, dimension(N_SLS) :: tau_s
+ double precision T_c_source
+
+ logical :: ACTUALLY_STORE_ARRAYS,ABSORBING_CONDITIONS
+
+ !local parameters
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm
+ ! parameters needed to store the radii of the grid points in the spherically symmetric Earth
+ double precision :: rmin,rmax
+ ! to define the central cube in the inner core
+ double precision :: radius_cube
+ double precision :: xgrid_central_cube,ygrid_central_cube,zgrid_central_cube
+ integer ix,iy,iz,ia
+ integer nx_central_cube,ny_central_cube,nz_central_cube
+ ! the height at which the central cube is cut
+ integer :: nz_inf_limit
+
+
+
+ ! 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,myrank,ABSORBING_CONDITIONS, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,nspec_actually, &
+ 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
+ rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
+ xigll,yigll,zigll)
+ enddo
+ enddo
+ enddo
+
+ end subroutine create_central_cube
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_central_cube_buffers.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube_buffers.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_central_cube_buffers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_central_cube_buffers.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!
+!--- create 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/src/create_chunk_buffers.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_chunk_buffers.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_chunk_buffers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_chunk_buffers.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,981 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! subroutine 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)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ 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
+ 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 NGLOB2DMAX_XY
+ 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)
+ double precision xread1D(NGLOB1D_RADIAL_MAX)
+ double precision yread1D(NGLOB1D_RADIAL_MAX)
+ double precision zread1D(NGLOB1D_RADIAL_MAX)
+ double precision xdummy,ydummy,zdummy
+ integer ipoin1D
+
+! 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, njunk
+ 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,filename_in,filename_out
+
+! 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
+
+ ! initializes counters
+ NUM_FACES = 0
+ NUM_MSG_TYPES = 0
+ iproc_xi_send = 0
+ iproc_xi_receive = 0
+ iproc_eta_send = 0
+ iproc_eta_receive = 0
+ iproc_edge_send = 0
+ iproc_edge_receive = 0
+ iedge = 0
+ ichunk_receive = 0
+ ichunk_send = 0
+
+! 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
+
+! define maximum size for message buffers
+ NGLOB2DMAX_XY = max(NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX)
+
+! 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
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='unknown')
+
+ endif
+
+! 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
+ 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
+ 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
+
+! create the name of the database for each slice
+ call create_name_database(prname,iproc,iregion_code,LOCAL_PATH)
+
+! open file for 2D buffer
+ 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
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//'boundary.bin',status='old',action='read',form='unformatted')
+ read(IIN) nspec2D_xmin
+ read(IIN) nspec2D_xmax
+ read(IIN) nspec2D_ymin
+ read(IIN) nspec2D_ymax
+ read(IIN) njunk
+ read(IIN) njunk
+
+ read(IIN) ibelm_xmin
+ read(IIN) ibelm_xmax
+ read(IIN) ibelm_ymin
+ read(IIN) ibelm_ymax
+ close(IIN)
+
+! read 1D buffers to remove corner points
+ open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='old',action='read')
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ read(IIN,*) ibool1D_leftxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
+ enddo
+ close(IIN)
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='old',action='read')
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ read(IIN,*) ibool1D_rightxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
+ enddo
+ close(IIN)
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='old',action='read')
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ read(IIN,*) ibool1D_leftxi_righteta(ipoin1D),xdummy,ydummy,zdummy
+ enddo
+ close(IIN)
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='old',action='read')
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ read(IIN,*) ibool1D_rightxi_righteta(ipoin1D),xdummy,ydummy,zdummy
+ enddo
+ 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(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
+
+ 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(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
+
+ 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(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
+
+ 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(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
+
+ 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
+ write(IOUT_BUFFERS,*) npoin2D
+ do ipoin2D = 1,npoin2D
+ write(IOUT_BUFFERS,*) ibool_selected(ipoin2D), &
+ xstore_selected(ipoin2D),ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+ enddo
+
+ 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
+
+ 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
+
+!
+!---- 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
+
+ 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
+
+! pick the correct 1D buffer
+! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
+ if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
+ filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt'
+ NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
+ filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt'
+ NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
+ filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt'
+ NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
+ filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt'
+ NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ else
+ call exit_MPI(myrank,'incorrect corner coordinates')
+ endif
+
+! read 1D buffer for corner
+ open(unit=IIN,file=filename_in,status='old',action='read')
+ do ipoin1D = 1,NGLOB1D_RADIAL
+ read(IIN,*) ibool1D(ipoin1D), &
+ xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
+ enddo
+ 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,xread1D,yread1D,zread1D, &
+ ibool1D,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+! check that no duplicates have been found
+ if(nglob /= NGLOB1D_RADIAL) call exit_MPI(myrank,'duplicates found for corners')
+
+! write file with 1D buffer for corner
+ open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
+ write(IOUT_BUFFERS,*) NGLOB1D_RADIAL
+ do ipoin1D = 1,NGLOB1D_RADIAL
+ write(IOUT_BUFFERS,*) ibool1D(ipoin1D), &
+ xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
+ enddo
+ close(IOUT_BUFFERS)
+
+! end of section done only if right processor for MPI
+ endif
+
+ enddo
+
+ enddo
+
+ 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/src/create_doubling_elements.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_doubling_elements.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_doubling_elements.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_doubling_elements.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_doubling_elements(myrank,ilayer,ichunk,ispec,ipass, &
+ ifirst_region,ilast_region,iregion_code, &
+ nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ ner,ratio_sampling_array,r_top,r_bottom, &
+ xstore,ystore,zstore,xigll,yigll,zigll, &
+ shape3D,dershape2D_bottom, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ rmin,rmax,r_moho,r_400,r_670, &
+ rhostore,dvpstore,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, &
+ nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore,&
+ nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
+ rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB,ACTUALLY_STORE_ARRAYS, &
+ NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
+ 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, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta)
+
+
+! adds doubling elements to the different regions of the mesh
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer :: myrank,ilayer,ichunk,ispec,ipass,ifirst_region,ilast_region
+ ! code for the four regions of the mesh
+ integer iregion_code
+ ! correct number of spectral elements in each block depending on chunk type
+ integer nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS
+ integer NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+
+! 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)
+
+! Gauss-Lobatto-Legendre points and weights of integration
+ double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
+
+! 3D shape functions and their derivatives
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+
+! 2D shape functions and their derivatives
+ double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+
+ logical INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
+
+ double precision RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+! parameters needed to store the radii of the grid points in the spherically symmetric Earth
+ double precision rmin,rmax
+ double precision r_moho,r_400,r_670
+
+! for model density and anisotropy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ integer nspec_ani
+ 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
+
+! arrays with mesh parameters
+ integer nspec_actually
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+! Stacey, indices for Clayton-Engquist absorbing conditions
+ integer nspec_stacey
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
+
+! boundary locator
+ logical iboun(6,nspec)
+
+! MPI cut-planes parameters along xi and along eta
+ logical, dimension(2,nspec) :: iMPIcut_xi,iMPIcut_eta
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+ integer iproc_xi,iproc_eta
+
+! attenuation
+ integer nspec_att
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
+ double precision, dimension(N_SLS) :: tau_s
+ double precision T_c_source
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+ integer idoubling(nspec)
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ logical :: USE_ONE_LAYER_SB
+ logical :: ACTUALLY_STORE_ARRAYS
+
+! Boundary Mesh
+ integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
+ integer ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO)
+ integer ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400)
+ integer ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670)
+ real(kind=CUSTOM_REAL) normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO)
+ real(kind=CUSTOM_REAL) normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400)
+ real(kind=CUSTOM_REAL) normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670)
+ real(kind=CUSTOM_REAL) jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO)
+ real(kind=CUSTOM_REAL) jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400)
+ real(kind=CUSTOM_REAL) jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670)
+
+ integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot
+
+ integer :: offset_proc_xi,offset_proc_eta
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+
+ ! local parameters
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+ double precision, dimension(NGNOD) :: offset_x,offset_y,offset_z
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm
+ double precision :: r1,r2,r3,r4,r5,r6,r7,r8
+ ! mesh doubling superbrick
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+ integer :: ix_elem,iy_elem,iz_elem,ignod,ispec_superbrick,case_xi,case_eta
+ integer :: step_mult,subblock_num
+ integer :: nspec_sb
+ logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
+ logical :: is_superbrick
+
+
+! 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 (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
+ 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,myrank,ABSORBING_CONDITIONS, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,nspec_actually, &
+ 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
+ rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
+ xigll,yigll,zigll)
+
+ ! 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
+
+ end subroutine create_doubling_elements
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_header_file.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_header_file.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_header_file.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_header_file.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,242 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create 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, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION,CASE_3D, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ 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,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
+
+
+! 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,OCEANS,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, &
+ SIMULATION_TYPE,SAVE_FORWARD,MOVIE_VOLUME)
+
+ print *
+ print *,'edit file OUTPUT_FILES/values_from_mesher.h to see'
+ print *,'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 *,'time-stepping of the solver will be: ',DT
+ print *
+ if(MOVIE_SURFACE .or. MOVIE_VOLUME) then
+ print *,'MOVIE_VOLUME:',MOVIE_VOLUME
+ print *,'MOVIE_SURFACE:',MOVIE_SURFACE
+ print *,'Saving movie frames every',NTSTEP_BETWEEN_FRAMES
+ endif
+ 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% or 90%'
+ print *,' of the memory installed per core)'
+ 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/src/create_mass_matrices.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_mass_matrices.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_mass_matrices.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_mass_matrices.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,228 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_mass_matrices(myrank,nspec,idoubling,wxgll,wygll,wzgll,ibool, &
+ nspec_actually,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ iregion_code,nglob,rmass,rhostore,kappavstore, &
+ nglob_oceans,rmass_ocean_load,NSPEC2D_TOP,ibelm_top,jacobian2D_top, &
+ xstore,ystore,zstore,RHO_OCEANS)
+
+! creates rmass and rmass_ocean_load
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer myrank,nspec
+
+ integer idoubling(nspec)
+
+ double precision wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer nspec_actually
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+ integer iregion_code
+
+ ! mass matrix
+ integer nglob
+ real(kind=CUSTOM_REAL), dimension(nglob) :: rmass
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,kappavstore
+
+ ! ocean mass matrix
+ integer nglob_oceans
+ real(kind=CUSTOM_REAL), dimension(nglob_oceans) :: rmass_ocean_load
+
+ integer NSPEC2D_TOP
+ integer, dimension(NSPEC2D_TOP) :: ibelm_top
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP) :: jacobian2D_top
+
+ ! 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)
+
+ double precision RHO_OCEANS
+
+ ! local parameters
+ double precision weight
+ double precision xval,yval,zval,rval,thetaval,phival
+ double precision lat,lon,colat
+ double precision elevation,height_oceans
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+
+ integer :: ispec,i,j,k,iglobnum
+ integer :: ix_oceans,iy_oceans,iz_oceans,ispec_oceans,ispec2D_top_crust
+
+
+ ! initializes
+ rmass(:) = 0._CUSTOM_REAL
+
+ do ispec=1,nspec
+
+ ! suppress fictitious elements in central cube
+ if(idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ iglobnum = ibool(i,j,k,ispec)
+
+ ! compute the jacobian
+ xixl = xixstore(i,j,k,ispec)
+ xiyl = xiystore(i,j,k,ispec)
+ xizl = xizstore(i,j,k,ispec)
+ etaxl = etaxstore(i,j,k,ispec)
+ etayl = etaystore(i,j,k,ispec)
+ etazl = etazstore(i,j,k,ispec)
+ gammaxl = gammaxstore(i,j,k,ispec)
+ gammayl = gammaystore(i,j,k,ispec)
+ gammazl = gammazstore(i,j,k,ispec)
+
+ 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(i,j,k,ispec)) * dble(jacobianl) * weight)
+ else
+ rmass(iglobnum) = rmass(iglobnum) + rhostore(i,j,k,ispec) * 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(i,j,k,ispec)) / dble(kappavstore(i,j,k,ispec)))
+ else
+ rmass(iglobnum) = rmass(iglobnum) + &
+ jacobianl * weight * rhostore(i,j,k,ispec) / kappavstore(i,j,k,ispec)
+ endif
+
+ else
+ call exit_MPI(myrank,'wrong region code')
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! save ocean load mass matrix as well if oceans
+ if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
+
+ ! create ocean load mass matrix for degrees of freedom at ocean bottom
+ rmass_ocean_load(:) = 0._CUSTOM_REAL
+
+ ! add contribution of the oceans
+ ! for surface elements exactly at the top of the crust (ocean bottom)
+ do ispec2D_top_crust = 1,NSPEC2D_TOP
+
+ ispec_oceans = ibelm_top(ispec2D_top_crust)
+
+ iz_oceans = NGLLZ
+
+ do ix_oceans = 1,NGLLX
+ do iy_oceans = 1,NGLLY
+
+ iglobnum=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+
+ ! if 3D Earth, compute local height of oceans
+ if(CASE_3D) then
+
+ ! get coordinates of current point
+ xval = xstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+ yval = ystore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+ zval = zstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+
+ ! map to latitude and longitude for bathymetry routine
+ call xyz_2_rthetaphi_dble(xval,yval,zval,rval,thetaval,phival)
+ call reduce(thetaval,phival)
+
+ ! convert the geocentric colatitude to a geographic colatitude
+ colat = PI/2.0d0 - datan(1.006760466d0*dcos(thetaval)/dmax1(TINYVAL,dsin(thetaval)))
+
+ ! get geographic latitude and longitude in degrees
+ lat = 90.0d0 - colat*180.0d0/PI
+ lon = phival*180.0d0/PI
+ elevation = 0.d0
+
+ ! compute elevation at current point
+ call get_topo_bathy(lat,lon,elevation,ibathy_topo)
+
+ ! non-dimensionalize the elevation, which is in meters
+ ! and suppress positive elevation, which means no oceans
+ if(elevation >= - MINIMUM_THICKNESS_3D_OCEANS) then
+ height_oceans = 0.d0
+ else
+ height_oceans = dabs(elevation) / R_EARTH
+ endif
+
+ else
+ ! if 1D Earth, use oceans of constant thickness everywhere
+ height_oceans = THICKNESS_OCEANS_PREM
+ endif
+
+ ! take into account inertia of water column
+ weight = wxgll(ix_oceans)*wygll(iy_oceans)*dble(jacobian2D_top(ix_oceans,iy_oceans,ispec2D_top_crust)) &
+ * dble(RHO_OCEANS) * height_oceans
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + sngl(weight)
+ else
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + weight
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+ ! add regular mass matrix to ocean load contribution
+ rmass_ocean_load(:) = rmass_ocean_load(:) + rmass(:)
+
+ endif
+
+ end subroutine create_mass_matrices
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_movie_AVS_DX.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_AVS_DX.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_movie_AVS_DX.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_movie_AVS_DX.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1024 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!
+!--- create a movie of radial component of surface displacement
+!--- in AVS or OpenDX format
+!
+
+ program xcreate_movie_AVS_DX
+
+ implicit none
+
+ integer it1,it2
+ integer iformat
+
+! parameters read from parameter file
+ integer NEX_XI,NEX_ETA
+ integer NSTEP,NTSTEP_BETWEEN_FRAMES,NCHUNKS
+ integer NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
+ logical MOVIE_SURFACE
+
+! ************** PROGRAM STARTS HERE **************
+
+ call read_AVS_DX_parameters(NEX_XI,NEX_ETA, &
+ NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NCHUNKS,MOVIE_SURFACE, &
+ NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
+
+ if(.not. MOVIE_SURFACE) stop 'movie frames were not saved by the solver'
+
+ print *,'1 = create files in OpenDX format'
+ print *,'2 = create files in AVS UCD format with individual files'
+ print *,'3 = create files in AVS UCD format with one time-dependent file'
+ print *,'4 = create files in GMT xyz Ascii long/lat/Uz format'
+ print *,'any other value = exit'
+ print *
+ print *,'enter value:'
+ read(5,*) iformat
+ if(iformat<1 .or. iformat>4) stop 'exiting...'
+
+ print *,'movie frames have been saved every ',NTSTEP_BETWEEN_FRAMES,' time steps'
+ print *
+
+ print *,'enter first time step of movie (e.g. 1)'
+ read(5,*) it1
+
+ print *,'enter last time step of movie (e.g. ',NSTEP,')'
+ read(5,*) it2
+
+! run the main program
+ call create_movie_AVS_DX(iformat,it1,it2, &
+ NEX_XI,NEX_ETA, &
+ NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NCHUNKS, &
+ NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
+
+ end program xcreate_movie_AVS_DX
+
+!
+!=====================================================================
+!
+
+ subroutine create_movie_AVS_DX(iformat,it1,it2,NEX_XI,NEX_ETA,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NCHUNKS,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
+
+ implicit none
+
+ include "constants.h"
+
+! threshold in percent of the maximum below which we cut the amplitude
+ real(kind=CUSTOM_REAL), parameter :: THRESHOLD = 1._CUSTOM_REAL / 100._CUSTOM_REAL
+
+! flag to apply non linear scaling to normalized norm of displacement
+ logical, parameter :: NONLINEAR_SCALING = .false.
+ logical, parameter :: FIX_SCALING = .false. ! uses fixed max_value to normalize instead of max of current wavefield
+ real,parameter:: MAX_VALUE = 6.77e-4
+
+! coefficient of power law used for non linear scaling
+ real(kind=CUSTOM_REAL), parameter :: POWER_SCALING = 0.30_CUSTOM_REAL
+
+! flag to cut amplitude below a certain threshold
+ logical, parameter :: APPLY_THRESHOLD = .true.
+
+ integer i,j,it
+ integer it1,it2
+ integer nspectot_AVS_max
+ integer ispec
+ integer ibool_number,ibool_number1,ibool_number2,ibool_number3,ibool_number4
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: x,y,z,displn
+ real(kind=CUSTOM_REAL) xcoord,ycoord,zcoord,rval,thetaval,phival,lat,long
+ real(kind=CUSTOM_REAL) displx,disply,displz
+ real(kind=CUSTOM_REAL) normal_x,normal_y,normal_z
+ double precision min_field_current,max_field_current,max_absol
+ logical USE_OPENDX,UNIQUE_FILE,USE_GMT,USE_AVS
+ integer iformat,nframes,iframe
+
+ character(len=150) outputname
+
+ integer iproc,ipoin
+
+! for sorting routine
+ integer npointot,ilocnum,nglob,ielm,ieoff,ispecloc
+ integer, dimension(:), allocatable :: iglob,loc,ireorder
+ logical, dimension(:), allocatable :: ifseg,mask_point
+ double precision, dimension(:), allocatable :: xp,yp,zp,xp_save,yp_save,zp_save,field_display
+
+! for dynamic memory allocation
+ integer ierror
+
+! movie files stored by solver
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_ux,store_val_uy,store_val_uz
+
+! parameters read from file or deduced from parameters read from file
+ integer NEX_XI,NEX_ETA
+ integer NSTEP,NTSTEP_BETWEEN_FRAMES,NCHUNKS
+ integer NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
+
+ character(len=150) OUTPUT_FILES
+
+! --------------------------------------
+
+ if(iformat == 1) then
+ USE_OPENDX = .true.
+ USE_AVS = .false.
+ USE_GMT = .false.
+ UNIQUE_FILE = .false.
+ else if(iformat == 2) then
+ USE_OPENDX = .false.
+ USE_AVS = .true.
+ USE_GMT = .false.
+ UNIQUE_FILE = .false.
+ else if(iformat == 3) then
+ USE_OPENDX = .false.
+ USE_AVS = .true.
+ USE_GMT = .false.
+ UNIQUE_FILE = .true.
+ else if(iformat == 4) then
+ USE_OPENDX = .false.
+ USE_AVS = .false.
+ USE_GMT = .true.
+ UNIQUE_FILE = .false.
+ else
+ stop 'error: invalid format'
+ endif
+
+ print *
+ print *,'Recombining all movie frames to create a movie'
+ print *
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ print *
+ print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
+ print *
+
+ ilocnum = NGLLX * NGLLY * NEX_PER_PROC_XI * NEX_PER_PROC_ETA
+
+ print *
+ print *,'Allocating arrays of size ',ilocnum*NPROCTOT
+ print *
+
+ allocate(store_val_x(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_x'
+
+ allocate(store_val_y(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_y'
+
+ allocate(store_val_z(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_z'
+
+ allocate(store_val_ux(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_ux'
+
+ allocate(store_val_uy(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_uy'
+
+ allocate(store_val_uz(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_uz'
+
+ allocate(x(NGLLX,NGLLY),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating x'
+
+ allocate(y(NGLLX,NGLLY),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating y'
+
+ allocate(z(NGLLX,NGLLY),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating z'
+
+ allocate(displn(NGLLX,NGLLY),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating displn'
+
+ print *
+ print *,'looping from ',it1,' to ',it2,' every ',NTSTEP_BETWEEN_FRAMES,' time steps'
+
+! count number of movie frames
+ nframes = 0
+ do it = it1,it2
+ if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) nframes = nframes + 1
+ enddo
+ print *
+ print *,'total number of frames will be ',nframes
+ if(nframes == 0) stop 'null number of frames'
+
+! Make OpenDX think that each "grid cell" between GLL points is actually
+! a finite element with four corners. This means that inside each real
+! spectral element one should have (NGLL-1)^2 OpenDX "elements"
+
+! define the total number of OpenDX "elements" at the surface
+ nspectot_AVS_max = NCHUNKS * NEX_XI * NEX_ETA * (NGLLX-1) * (NGLLY-1)
+
+ print *
+ print *,'there are a total of ',nspectot_AVS_max,' OpenDX "elements" at the surface'
+ print *
+
+! maximum theoretical number of points at the surface
+ npointot = NGNOD2D_AVS_DX * nspectot_AVS_max
+
+ print *
+ print *,'Allocating arrays of size ',npointot
+ print *
+
+! allocate arrays for sorting routine
+ allocate(iglob(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating iglob'
+
+ allocate(loc(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating loc'
+
+ allocate(ifseg(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating ifseg'
+
+ allocate(xp(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating xp'
+
+ allocate(yp(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating yp'
+
+ allocate(zp(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating zp'
+
+ allocate(xp_save(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating xp_save'
+
+ allocate(yp_save(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating yp_save'
+
+ allocate(zp_save(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating zp_save'
+
+ allocate(field_display(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating field_display'
+
+ allocate(mask_point(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating mask_point'
+
+ allocate(ireorder(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating ireorder'
+
+!--- ****** read data saved by solver ******
+
+ print *
+
+ if(APPLY_THRESHOLD) print *,'Will apply a threshold to amplitude below ',100.*THRESHOLD,' %'
+
+ if(NONLINEAR_SCALING) print *,'Will apply a non linear scaling with coef ',POWER_SCALING
+
+! --------------------------------------
+
+ iframe = 0
+
+! loop on all the time steps in the range entered
+ do it = it1,it2
+
+! check if time step corresponds to a movie frame
+ if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+
+ iframe = iframe + 1
+
+ print *
+ print *,'reading snapshot time step ',it,' out of ',NSTEP
+ print *
+
+! read all the elements from the same file
+ write(outputname,"('/moviedata',i6.6)") it
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='old',action='read',form='unformatted')
+ read(IOUT) store_val_x
+ read(IOUT) store_val_y
+ read(IOUT) store_val_z
+ read(IOUT) store_val_ux
+ read(IOUT) store_val_uy
+ read(IOUT) store_val_uz
+ close(IOUT)
+
+! clear number of elements kept
+ ispec = 0
+
+! read points for all the slices
+ do iproc = 0,NPROCTOT-1
+
+! reset point number
+ ipoin = 0
+
+ do ispecloc = 1,NEX_PER_PROC_XI*NEX_PER_PROC_ETA
+
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ ipoin = ipoin + 1
+
+ xcoord = store_val_x(ipoin,iproc)
+ ycoord = store_val_y(ipoin,iproc)
+ zcoord = store_val_z(ipoin,iproc)
+
+ displx = store_val_ux(ipoin,iproc)
+ disply = store_val_uy(ipoin,iproc)
+ displz = store_val_uz(ipoin,iproc)
+
+! coordinates actually contain r theta phi, therefore convert back to x y z
+ rval = xcoord
+ thetaval = ycoord
+ phival = zcoord
+ call rthetaphi_2_xyz(xcoord,ycoord,zcoord,rval,thetaval,phival)
+
+! compute unit normal vector to the surface
+ normal_x = xcoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
+ normal_y = ycoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
+ normal_z = zcoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
+
+! save the results for this element
+ x(i,j) = xcoord
+ y(i,j) = ycoord
+ z(i,j) = zcoord
+ displn(i,j) = displx*normal_x + disply*normal_y + displz*normal_z
+
+ enddo
+ enddo
+
+! assign the values of the corners of the OpenDX "elements"
+ ispec = ispec + 1
+ ielm = (NGLLX-1)*(NGLLY-1)*(ispec-1)
+ do j = 1,NGLLY-1
+ do i = 1,NGLLX-1
+ ieoff = NGNOD2D_AVS_DX*(ielm+(i-1)+(j-1)*(NGLLX-1))
+ do ilocnum = 1,NGNOD2D_AVS_DX
+ if(ilocnum == 1) then
+ xp(ieoff+ilocnum) = dble(x(i,j))
+ yp(ieoff+ilocnum) = dble(y(i,j))
+ zp(ieoff+ilocnum) = dble(z(i,j))
+ field_display(ieoff+ilocnum) = dble(displn(i,j))
+ elseif(ilocnum == 2) then
+ xp(ieoff+ilocnum) = dble(x(i+1,j))
+ yp(ieoff+ilocnum) = dble(y(i+1,j))
+ zp(ieoff+ilocnum) = dble(z(i+1,j))
+ field_display(ieoff+ilocnum) = dble(displn(i+1,j))
+ elseif(ilocnum == 3) then
+ xp(ieoff+ilocnum) = dble(x(i+1,j+1))
+ yp(ieoff+ilocnum) = dble(y(i+1,j+1))
+ zp(ieoff+ilocnum) = dble(z(i+1,j+1))
+ field_display(ieoff+ilocnum) = dble(displn(i+1,j+1))
+ else
+ xp(ieoff+ilocnum) = dble(x(i,j+1))
+ yp(ieoff+ilocnum) = dble(y(i,j+1))
+ zp(ieoff+ilocnum) = dble(z(i,j+1))
+ field_display(ieoff+ilocnum) = dble(displn(i,j+1))
+ endif
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+ enddo
+
+! compute min and max of data value to normalize
+ min_field_current = minval(field_display(:))
+ max_field_current = maxval(field_display(:))
+
+! make sure range is always symmetric and center is in zero
+! this assumption works only for fields that can be negative
+! would not work for norm of vector for instance
+! (we would lose half of the color palette if no negative values)
+ max_absol = max(abs(min_field_current),abs(max_field_current))
+ min_field_current = - max_absol
+ max_field_current = + max_absol
+
+! print minimum and maximum amplitude in current snapshot
+ print *
+ print *,'minimum amplitude in current snapshot = ',min_field_current
+ print *,'maximum amplitude in current snapshot = ',max_field_current
+ if( FIX_SCALING ) then
+ print *,' to be normalized by : ',MAX_VALUE
+ if( max_field_current > MAX_VALUE ) stop 'increase MAX_VALUE'
+ endif
+ print *
+
+
+
+! normalize field to [0:1]
+ print *,'normalizing... '
+ if( FIX_SCALING ) then
+ field_display(:) = (field_display(:) + MAX_VALUE) / (2.0*MAX_VALUE)
+ else
+ field_display(:) = (field_display(:) - min_field_current) / (max_field_current - min_field_current)
+ endif
+! rescale to [-1,1]
+ field_display(:) = 2.*field_display(:) - 1.
+
+! apply threshold to normalized field
+ if(APPLY_THRESHOLD) then
+ print *,'thresholding... '
+ where(abs(field_display(:)) <= THRESHOLD) field_display = 0.
+ endif
+
+! apply non linear scaling to normalized field if needed
+ if(NONLINEAR_SCALING) then
+ print *,'nonlinear scaling... '
+ where(field_display(:) >= 0.)
+ field_display = field_display ** POWER_SCALING
+ elsewhere
+ field_display = - abs(field_display) ** POWER_SCALING
+ endwhere
+ endif
+
+ print *,'color scaling... '
+! map back to [0,1]
+ field_display(:) = (field_display(:) + 1.) / 2.
+
+! map field to [0:255] for AVS color scale
+ field_display(:) = 255. * field_display(:)
+
+
+! copy coordinate arrays since the sorting routine does not preserve them
+ print *,'sorting... '
+ xp_save(:) = xp(:)
+ yp_save(:) = yp(:)
+ zp_save(:) = zp(:)
+
+!--- sort the list based upon coordinates to get rid of multiples
+ print *,'sorting list of points'
+ call get_global_AVS(nspectot_AVS_max,xp,yp,zp,iglob,loc,ifseg,nglob,npointot)
+
+!--- print total number of points found
+ print *
+ print *,'found a total of ',nglob,' points'
+ print *,'initial number of points (with multiples) was ',npointot
+
+!--- ****** create AVS file using sorted list ******
+
+! create file name and open file
+ if(USE_OPENDX) then
+ write(outputname,"('/DX_movie_',i6.6,'.dx')") it
+ open(unit=11,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',nglob,' data follows'
+ else if(USE_AVS) then
+ if(UNIQUE_FILE .and. iframe == 1) then
+ open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_movie_all.inp',status='unknown')
+ write(11,*) nframes
+ write(11,*) 'data'
+ write(11,"('step',i1,' image',i1)") 1,1
+ write(11,*) nglob,' ',nspectot_AVS_max
+ else if(.not. UNIQUE_FILE) then
+ write(outputname,"('/AVS_movie_',i6.6,'.inp')") it
+ open(unit=11,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(11,*) nglob,' ',nspectot_AVS_max,' 1 0 0'
+ endif
+ else if(USE_GMT) then
+ write(outputname,"('/gmt_movie_',i6.6,'.xyz')") it
+ open(unit=11,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ else
+ stop 'wrong output format selected'
+ endif
+
+ if(USE_GMT) then
+
+ ! output list of points
+ mask_point = .false.
+ do ispec=1,nspectot_AVS_max
+ ieoff = NGNOD2D_AVS_DX*(ispec-1)
+ ! four points for each element
+ do ilocnum = 1,NGNOD2D_AVS_DX
+ ibool_number = iglob(ilocnum+ieoff)
+ if(.not. mask_point(ibool_number)) then
+ xcoord = sngl(xp_save(ilocnum+ieoff))
+ ycoord = sngl(yp_save(ilocnum+ieoff))
+ zcoord = sngl(zp_save(ilocnum+ieoff))
+ call xyz_2_rthetaphi(xcoord,ycoord,zcoord,rval,thetaval,phival)
+
+ ! note: converts the geocentric colatitude to a geographic colatitude
+ if(.not. ASSUME_PERFECT_SPHERE) then
+ thetaval = PI/2.0d0 - &
+ datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dble(sin(thetaval))))
+ endif
+
+ lat = (PI/2.0-thetaval)*180.0/PI
+ long = phival*180.0/PI
+ if(long > 180.0) long = long-360.0
+ write(11,*) long,lat,sngl(field_display(ilocnum+ieoff))
+ endif
+ mask_point(ibool_number) = .true.
+ enddo
+ enddo
+
+ else
+! if unique file, output geometry only once
+ if(.not. UNIQUE_FILE .or. iframe == 1) then
+
+! output list of points
+ mask_point = .false.
+ ipoin = 0
+ do ispec=1,nspectot_AVS_max
+ ieoff = NGNOD2D_AVS_DX*(ispec-1)
+! four points for each element
+ do ilocnum = 1,NGNOD2D_AVS_DX
+ ibool_number = iglob(ilocnum+ieoff)
+ if(.not. mask_point(ibool_number)) then
+ ipoin = ipoin + 1
+ ireorder(ibool_number) = ipoin
+ if(USE_OPENDX) then
+ write(11,"(f10.7,1x,f10.7,1x,f10.7)") &
+ xp_save(ilocnum+ieoff),yp_save(ilocnum+ieoff),zp_save(ilocnum+ieoff)
+ else if(USE_AVS) then
+ write(11,"(i10,1x,f10.7,1x,f10.7,1x,f10.7)") ireorder(ibool_number), &
+ xp_save(ilocnum+ieoff),yp_save(ilocnum+ieoff),zp_save(ilocnum+ieoff)
+ endif
+ endif
+ mask_point(ibool_number) = .true.
+ enddo
+ enddo
+
+ if(USE_OPENDX) &
+ write(11,*) 'object 2 class array type int rank 1 shape 4 items ',nspectot_AVS_max,' data follows'
+
+! output list of elements
+ do ispec=1,nspectot_AVS_max
+ ieoff = NGNOD2D_AVS_DX*(ispec-1)
+! four points for each element
+ ibool_number1 = iglob(ieoff + 1)
+ ibool_number2 = iglob(ieoff + 2)
+ ibool_number3 = iglob(ieoff + 3)
+ ibool_number4 = iglob(ieoff + 4)
+ if(USE_OPENDX) then
+! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
+ write(11,"(i10,1x,i10,1x,i10,1x,i10)") ireorder(ibool_number1)-1, &
+ ireorder(ibool_number4)-1,ireorder(ibool_number2)-1,ireorder(ibool_number3)-1
+ else
+ write(11,"(i10,' 1 quad ',i10,1x,i10,1x,i10,1x,i10)") ispec,ireorder(ibool_number1), &
+ ireorder(ibool_number2),ireorder(ibool_number3),ireorder(ibool_number4)
+ endif
+ enddo
+
+ endif
+
+ if(USE_OPENDX) then
+ write(11,*) 'attribute "element type" string "quads"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items ',nglob,' data follows'
+ else
+ if(UNIQUE_FILE) then
+! step number for AVS multistep file
+ if(iframe > 1) then
+ if(iframe < 10) then
+ write(11,"('step',i1,' image',i1)") iframe,iframe
+ else if(iframe < 100) then
+ write(11,"('step',i2,' image',i2)") iframe,iframe
+ else if(iframe < 1000) then
+ write(11,"('step',i3,' image',i3)") iframe,iframe
+ else
+ write(11,"('step',i4,' image',i4)") iframe,iframe
+ endif
+ endif
+ write(11,*) '1 0'
+ endif
+! dummy text for labels
+ write(11,*) '1 1'
+ write(11,*) 'a, b'
+ endif
+
+! output data values
+ mask_point = .false.
+
+! output point data
+ do ispec=1,nspectot_AVS_max
+ ieoff = NGNOD2D_AVS_DX*(ispec-1)
+! four points for each element
+ do ilocnum = 1,NGNOD2D_AVS_DX
+ ibool_number = iglob(ilocnum+ieoff)
+ if(.not. mask_point(ibool_number)) then
+ if(USE_OPENDX) then
+ write(11,"(f7.2)") field_display(ilocnum+ieoff)
+ else
+ write(11,"(i10,1x,f7.2)") ireorder(ibool_number),field_display(ilocnum+ieoff)
+ endif
+ endif
+ mask_point(ibool_number) = .true.
+ enddo
+ enddo
+
+! define OpenDX field
+ if(USE_OPENDX) then
+ write(11,*) 'attribute "dep" string "positions"'
+ write(11,*) 'object "irregular positions irregular connections" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+ endif
+
+! end of test for GMT format
+ endif
+
+ if(.not. UNIQUE_FILE) close(11)
+
+! end of loop and test on all the time steps for all the movie images
+ endif
+ enddo
+
+ if(UNIQUE_FILE) close(11)
+
+ print *
+ print *,'done creating movie'
+ print *
+ if(USE_OPENDX) print *,'DX files are stored in ', trim(OUTPUT_FILES), '/DX_*.dx'
+ if(USE_AVS) print *,'AVS files are stored in ', trim(OUTPUT_FILES), '/AVS_*.inp'
+ if(USE_GMT) print *,'GMT files are stored in ', trim(OUTPUT_FILES), '/gmt_*.xyz'
+ print *
+
+ end subroutine create_movie_AVS_DX
+
+!
+!=====================================================================
+!
+
+ subroutine read_params_and_create_movie
+
+!
+! This routine is called by the Pyrized version.
+!
+
+ implicit none
+
+ integer it1,it2
+ integer iformat
+
+! parameters read from parameter file
+ integer NEX_XI,NEX_ETA
+ integer NSTEP,NTSTEP_BETWEEN_FRAMES,NCHUNKS
+ integer NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
+ logical MOVIE_SURFACE
+
+ integer, external :: err_occurred
+
+ call read_AVS_DX_parameters(NEX_XI,NEX_ETA, &
+ NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NCHUNKS,MOVIE_SURFACE, &
+ NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
+
+! read additional parameters for making movies
+ call read_value_integer(iformat, 'format')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(it1, 'beginning')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(it2, 'end')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! run the main program
+ call create_movie_AVS_DX(iformat,it1,it2, &
+ NEX_XI,NEX_ETA, &
+ NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NCHUNKS, &
+ NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
+
+ end subroutine read_params_and_create_movie
+
+! ------------------------------------------------------------------
+
+ subroutine read_AVS_DX_parameters(NEX_XI,NEX_ETA, &
+ NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NCHUNKS,MOVIE_SURFACE, &
+ NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA)
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ 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
+
+! 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
+ 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
+
+! 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
+
+ character(len=150) LOCAL_PATH,MODEL
+ 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
+
+ print *
+ print *,'reading parameter file'
+ print *
+
+! read the parameter file and compute additional parameters
+
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
+
+ if(MOVIE_COARSE) stop 'create_movie_AVS_DX does not work with MOVIE_COARSE'
+
+ end subroutine read_AVS_DX_parameters
+
+! ------------------------------------------------------------------
+
+ subroutine get_global_AVS(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
+
+! leave sorting subroutines in same source file to allow for inlining
+
+ implicit none
+
+ include "constants.h"
+
+ integer npointot
+ integer iglob(npointot),loc(npointot)
+ logical ifseg(npointot)
+ double precision xp(npointot),yp(npointot),zp(npointot)
+ integer nspec,nglob
+
+ integer ispec,i,j
+ integer ieoff,ilocnum,nseg,ioff,iseg,ig
+
+! for dynamic memory allocation
+ integer ierror
+
+ integer, dimension(:), allocatable :: ind,ninseg,iwork
+ double precision, dimension(:), allocatable :: work
+
+ print *
+ print *,'Allocating arrays of size ',npointot
+ print *
+
+! dynamically allocate arrays
+ allocate(ind(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating ind'
+
+ allocate(ninseg(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating ninseg'
+
+ allocate(iwork(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating iwork'
+
+ allocate(work(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating work'
+
+! establish initial pointers
+ do ispec=1,nspec
+ ieoff=NGNOD2D_AVS_DX*(ispec-1)
+ do ilocnum=1,NGNOD2D_AVS_DX
+ loc(ieoff+ilocnum)=ieoff+ilocnum
+ 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)
+
+! -----------------------------------
+
+! get_global_AVS internal procedures follow
+
+! sorting routines put in same file to allow for inlining
+
+ contains
+
+! -----------------------------------
+
+ 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
+
+! ------------------------------------------------------------------
+
+ end subroutine get_global_AVS
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_movie_GMT_global.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_GMT_global.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_movie_GMT_global.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_movie_GMT_global.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,790 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!
+!--- create a movie of radial component of surface displacement in GMT format
+!
+
+ program create_movie_GMT_global
+
+! reads in files: OUTPUT_FILES/moviedata******
+!
+! and creates new files: ascii_movie_*** (ascii option) /or/ bin_movie_*** (binary option)
+!
+! these files can then be visualized using GMT, the Generic Mapping Tools
+! ( http://www.soest.hawaii.edu/GMT/ )
+!
+! example scripts can be found in: UTILS/Visualization/GMT/
+
+ implicit none
+
+ include "constants.h"
+
+!---------------------
+! USER PARAMETER
+
+ ! to avoid flickering in movies, the displacement field will get normalized with an
+ ! averaged maximum value over the past few, available snapshots
+ logical,parameter :: USE_AVERAGED_MAXIMUM = .true.
+
+ ! minimum number of frames to average maxima
+ integer,parameter :: AVERAGE_MINIMUM = 5
+
+ ! muting source region
+ logical, parameter :: MUTE_SOURCE = .true.
+ real(kind=CUSTOM_REAL) :: RADIUS_TO_MUTE = 1.0 ! start radius in degrees
+ real(kind=CUSTOM_REAL) :: STARTTIME_TO_MUTE = 2.0 ! factor times hdur_movie
+
+ ! normalizes output values
+ logical, parameter :: NORMALIZE_VALUES = .true.
+
+!---------------------
+
+ integer i,j,it
+ integer it1,it2
+ integer ispec
+
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: x,y,z,displn
+ real(kind=CUSTOM_REAL) xcoord,ycoord,zcoord,rval,thetaval,phival
+ real(kind=CUSTOM_REAL) RRval,rhoval
+ real(kind=CUSTOM_REAL) displx,disply,displz
+ real(kind=CUSTOM_REAL) normal_x,normal_y,normal_z
+ real(kind=CUSTOM_REAL) thetahat_x,thetahat_y,thetahat_z
+ real(kind=CUSTOM_REAL) phihat_x,phihat_y
+
+ ! to average maxima over past few steps
+ double precision min_field_current,max_field_current,max_absol,max_average
+ double precision,dimension(:),allocatable :: max_history
+ integer :: nmax_history,imax
+
+ real disp,lat,long
+ integer nframes,iframe,USE_COMPONENT
+
+ character(len=150) outputname
+
+ integer iproc,ipoin
+
+! for sorting routine
+ integer npointot,ilocnum,ielm,ieoff,ispecloc,NIT
+ double precision, dimension(:), allocatable :: xp,yp,zp,field_display
+
+! for dynamic memory allocation
+ integer ierror
+
+! movie files stored by solver
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_ux,store_val_uy,store_val_uz
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ 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
+
+! 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
+
+
+ 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,OUTPUT_BINARY
+
+ 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
+
+ real(kind=CUSTOM_REAL) :: LAT_SOURCE,LON_SOURCE,DEP_SOURCE
+ real(kind=CUSTOM_REAL) :: dist_lon,dist_lat,mute_factor
+ character(len=256) line
+
+! ************** PROGRAM STARTS HERE **************
+
+ print *
+ print *,'Recombining all movie frames to create a movie'
+ print *,'Run this program from the directory containing directories DATA and OUTPUT_FILES'
+
+ print *
+ print *,'reading parameter file'
+ print *
+
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
+
+ if(.not. MOVIE_SURFACE) stop 'movie frames were not saved by the solver'
+
+ print *
+ print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
+ print *
+ if(MOVIE_COARSE) then
+ ! note:
+ ! nex_per_proc_xi*nex_per_proc_eta = nex_xi*nex_eta/nproc = nspec2d_top(iregion_crust_mantle) used in specfem3D.f90
+ ! and ilocnum = nmovie_points = 2 * 2 * NEX_XI * NEX_ETA / NPROC
+ ilocnum = 2 * 2 * NEX_PER_PROC_XI*NEX_PER_PROC_ETA
+ NIT =NGLLX-1
+ else
+ ilocnum = NGLLX*NGLLY*NEX_PER_PROC_XI*NEX_PER_PROC_ETA
+ NIT = 1
+ endif
+ print *
+ print *,'Allocating arrays for reading data of size ',ilocnum*NPROCTOT,'=',6*ilocnum*NPROCTOT*CUSTOM_REAL/1000000,'MB'
+ print *
+
+ ! allocates movie arrays
+ allocate(store_val_x(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_x'
+
+ allocate(store_val_y(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_y'
+
+ allocate(store_val_z(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_z'
+
+ allocate(store_val_ux(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_ux'
+
+ allocate(store_val_uy(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_uy'
+
+ allocate(store_val_uz(ilocnum,0:NPROCTOT-1),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating store_val_uz'
+
+ allocate(x(NGLLX,NGLLY),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating x'
+
+ allocate(y(NGLLX,NGLLY),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating y'
+
+ allocate(z(NGLLX,NGLLY),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating z'
+
+ allocate(displn(NGLLX,NGLLY),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating displn'
+
+ print *,'movie frames have been saved every ',NTSTEP_BETWEEN_FRAMES,' time steps'
+ print *
+
+ ! user input
+ print *,'--------'
+ print *,'enter first time step of movie (e.g. 1)'
+ read(5,*) it1
+
+ print *,'enter last time step of movie (e.g. ',NSTEP,'or -1 for all)'
+ read(5,*) it2
+
+ print *,'enter component (e.g. 1=Z, 2=N, 3=E)'
+ read(5,*) USE_COMPONENT
+
+ print *,'enter output ascii (F) or binary (T)'
+ read(5,*) OUTPUT_BINARY
+ print *,'--------'
+
+ ! checks options
+ if( it2 == -1 ) it2 = NSTEP
+
+ print *
+ print *,'looping from ',it1,' to ',it2,' every ',NTSTEP_BETWEEN_FRAMES,' time steps'
+
+ ! counts number of movie frames
+ nframes = 0
+ do it = it1,it2
+ if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) nframes = nframes + 1
+ enddo
+ print *
+ print *,'total number of frames will be ',nframes
+ if(nframes == 0) stop 'null number of frames'
+
+ ! maximum theoretical number of points at the surface
+ if(MOVIE_COARSE) then
+ npointot = NCHUNKS * NEX_XI * NEX_ETA
+ else
+ npointot = NCHUNKS * NEX_XI * NEX_ETA * (NGLLX-1) * (NGLLY-1)
+ endif
+
+ print *
+ print *,'there are a total of ',npointot,' points on the surface.'
+ print *
+
+
+ print *
+ print *,'Allocating 4 outputdata arrays of size 4*CUSTOM_REAL',npointot,'=',4*npointot*CUSTOM_REAL/1000000,' MB'
+ print *
+
+ allocate(xp(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating xp'
+
+ allocate(yp(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating yp'
+
+ allocate(zp(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating zp'
+
+ allocate(field_display(npointot),stat=ierror)
+ if(ierror /= 0) stop 'error while allocating field_display'
+
+
+ ! initializes maxima history
+ if( USE_AVERAGED_MAXIMUM ) then
+ ! determines length of history
+ nmax_history = AVERAGE_MINIMUM + int( HDUR_MOVIE / (DT*NTSTEP_BETWEEN_FRAMES) * 1.5 )
+
+ ! allocates history array
+ allocate(max_history(nmax_history))
+ max_history(:) = 0.0d0
+
+ print *
+ print *,'Movie half-duration: ',HDUR_MOVIE,'(s)'
+ print *,'Frame step size : ',DT*NTSTEP_BETWEEN_FRAMES,'(s)'
+ print *,'Normalization by averaged maxima over ',nmax_history,'snapshots'
+ print *
+
+ if( MUTE_SOURCE ) then
+ ! initializes
+ LAT_SOURCE = -1000.0
+ LON_SOURCE = -1000.0
+
+ ! reads in source lat/lon
+ open(22,file="DATA/CMTSOLUTION",status='old',action='read',iostat=ierror )
+ if( ierror == 0 ) then
+ ! skip first line, event name,timeshift,half duration
+ read(22,*,iostat=ierror ) line ! PDE line
+ read(22,*,iostat=ierror ) line ! event name
+ read(22,*,iostat=ierror ) line ! timeshift
+ read(22,*,iostat=ierror ) line ! halfduration
+ ! latitude
+ read(22,'(a256)',iostat=ierror ) line
+ if( ierror == 0 ) read(line(10:len_trim(line)),*) LAT_SOURCE
+ ! longitude
+ read(22,'(a256)',iostat=ierror ) line
+ if( ierror == 0 ) read(line(11:len_trim(line)),*) LON_SOURCE
+ ! depth
+ read(22,'(a256)',iostat=ierror ) line
+ if( ierror == 0 ) read(line(11:len_trim(line)),*) DEP_SOURCE
+ close(22)
+ endif
+
+ print *,'muting source lat/lon/dep: ',LAT_SOURCE,LON_SOURCE,DEP_SOURCE
+
+ ! becomes time (s) from hypocenter to reach surface (using average 8 km/s p-wave speed)
+ DEP_SOURCE = DEP_SOURCE / 8.0
+
+ ! time when muting starts
+ STARTTIME_TO_MUTE = STARTTIME_TO_MUTE * HDUR_MOVIE + DEP_SOURCE
+
+ print *,'muting radius: ',RADIUS_TO_MUTE
+ print *,'muting starttime: ',STARTTIME_TO_MUTE,'(s)'
+ print *
+
+ ! colatitude [0, PI]
+ LAT_SOURCE = (90. - LAT_SOURCE)*PI/180.0
+
+ ! longitude [-PI, PI]
+ if( LON_SOURCE < -180.0 ) LON_SOURCE = LON_SOURCE + 360.0
+ if( LON_SOURCE > 180.0 ) LON_SOURCE = LON_SOURCE - 360.0
+ LON_SOURCE = LON_SOURCE *PI/180.0
+
+ ! mute radius in rad
+ RADIUS_TO_MUTE = RADIUS_TO_MUTE*PI/180.0
+ endif
+
+
+ endif
+ print *,'--------'
+
+!--- ****** read data saved by solver ******
+
+! --------------------------------------
+
+ iframe = 0
+
+! loop on all the time steps in the range entered
+ do it = it1,it2
+ ! check if time step corresponds to a movie frame
+ if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+
+ iframe = iframe + 1
+
+ ! mutes source region
+ if( MUTE_SOURCE ) then
+
+ ! muting radius grows/shrinks with time
+ if( (it-1)*DT > STARTTIME_TO_MUTE ) then
+
+ ! approximate wavefront travel distance in degrees (~3.5 km/s wave speed for surface waves)
+ mute_factor = 3.5 * (it-1)*DT / 6371. * 180./PI
+
+ ! approximate distance to source (in degrees)
+ do while ( mute_factor > 360. )
+ mute_factor = mute_factor - 360.
+ enddo
+ if( mute_factor > 180. ) mute_factor = 360. - mute_factor
+
+ ! limit size around source (in degrees)
+ !if( mute_factor < 10. ) then
+ ! mute_factor = 0.0
+ !endif
+ if( mute_factor > 80. ) then
+ mute_factor = 80.0
+ endif
+
+ print*,'muting radius: ',0.7 * mute_factor
+
+ RADIUS_TO_MUTE = 0.7 * mute_factor * PI/180.
+
+ else
+ ! mute_factor used at the beginning for scaling displacement values
+ if( STARTTIME_TO_MUTE > TINYVAL ) then
+ ! scales from 1 to 0
+ mute_factor = ( STARTTIME_TO_MUTE - (it-1)*DT ) / STARTTIME_TO_MUTE
+ if( mute_factor < TINYVAL ) mute_factor = TINYVAL
+ else
+ mute_factor = 1.0
+ endif
+ endif
+
+ endif
+
+ ! read all the elements from the same file
+ write(outputname,"('OUTPUT_FILES/moviedata',i6.6)") it
+ open(unit=IOUT,file=outputname,status='old',form='unformatted')
+
+ print *
+ print *,'reading snapshot time step ',it,' out of ',NSTEP,' file ',outputname
+ !print *
+
+ ! reads in point locations
+ ! (given as r theta phi for geocentric coordinate system)
+ read(IOUT) store_val_x
+ read(IOUT) store_val_y
+ read(IOUT) store_val_z
+
+ ! reads in associated values (velocity..)
+ read(IOUT) store_val_ux
+ read(IOUT) store_val_uy
+ read(IOUT) store_val_uz
+
+ close(IOUT)
+ !print *, 'finished reading ',outputname
+
+ ! clear number of elements kept
+ ispec = 0
+
+ ! read points for all the slices
+ print *,'Converting to geo-coordinates'
+ do iproc = 0,NPROCTOT-1
+ ! reset point number
+ ipoin = 0
+ do ispecloc = 1,NEX_PER_PROC_XI*NEX_PER_PROC_ETA
+ do j = 1,NGLLY,NIT
+ do i = 1,NGLLX,NIT
+ ipoin = ipoin + 1
+
+ ! coordinates actually contain r theta phi
+ xcoord = store_val_x(ipoin,iproc)
+ ycoord = store_val_y(ipoin,iproc)
+ zcoord = store_val_z(ipoin,iproc)
+
+ displx = store_val_ux(ipoin,iproc)
+ disply = store_val_uy(ipoin,iproc)
+ displz = store_val_uz(ipoin,iproc)
+
+ ! coordinates actually contain r theta phi, therefore convert back to x y z
+ rval = xcoord
+ thetaval = ycoord
+ phival = zcoord
+ call rthetaphi_2_xyz(xcoord,ycoord,zcoord,rval,thetaval,phival)
+
+ ! save the results for this element
+ x(i,j) = xcoord
+ y(i,j) = ycoord
+ z(i,j) = zcoord
+
+
+ if(USE_COMPONENT == 1) then
+ ! compute unit normal vector to the surface
+ RRval = sqrt(xcoord**2 + ycoord**2 + zcoord**2)
+ normal_x = xcoord / RRval
+ normal_y = ycoord / RRval
+ normal_z = zcoord / RRval
+
+ displn(i,j) = displx*normal_x + disply*normal_y + displz*normal_z
+
+ elseif(USE_COMPONENT == 2) then
+
+ ! compute unit tangent vector to the surface (N-S)
+ RRval = sqrt(xcoord**2 + ycoord**2 + zcoord**2)
+ rhoval = sqrt(xcoord**2 + ycoord**2)
+ thetahat_x = (zcoord*xcoord) / (rhoval*RRval)
+ thetahat_y = (zcoord*ycoord) / (rhoval*RRval)
+ thetahat_z = - rhoval/RRval
+
+ displn(i,j) = - (displx*thetahat_x + disply*thetahat_y + displz*thetahat_z)
+ elseif(USE_COMPONENT == 3) then
+
+ ! compute unit tangent to the surface (E-W)
+ rhoval = sqrt(xcoord**2 + ycoord**2)
+ phihat_x = -ycoord / rhoval
+ phihat_y = xcoord / rhoval
+
+ displn(i,j) = displx*phihat_x + disply*phihat_y
+ endif
+
+
+ ! mute values
+ if( MUTE_SOURCE ) then
+
+ ! distance in colatitude
+ ! note: this mixes geocentric (point location) and geographic (source location) coordinates;
+ ! since we only need approximate distances here, this should be fine for the muting region
+ dist_lat = thetaval - LAT_SOURCE
+
+ ! distance in longitude
+ ! checks source longitude range
+ if( LON_SOURCE - RADIUS_TO_MUTE < -PI .or. LON_SOURCE + RADIUS_TO_MUTE > PI ) then
+ ! source close to 180. longitudes, shifts range to [0, 2PI]
+ if( phival < 0.0 ) phival = phival + 2.0*PI
+ if( LON_SOURCE < 0.0 ) then
+ dist_lon = phival - (LON_SOURCE + 2.0*PI)
+ else
+ dist_lon = phival - LON_SOURCE
+ endif
+ else
+ ! source well between range to [-PI, PI]
+ ! shifts phival to be like LON_SOURCE between [-PI,PI]
+ if( phival > PI ) phival = phival - 2.0*PI
+ if( phival < -PI ) phival = phival + 2.0*PI
+
+ dist_lon = phival - LON_SOURCE
+ endif
+
+ ! mutes source region values
+ if ( ( dist_lat**2 + dist_lon**2 ) < RADIUS_TO_MUTE**2 ) then
+ ! muting takes account of the event time
+ if( (it-1)*DT > STARTTIME_TO_MUTE ) then
+ displn(i,j) = displn(i,j) * TINYVAL
+ else
+ displn(i,j) = displn(i,j) * mute_factor
+ endif
+ endif
+
+ endif
+
+
+ enddo !i
+ enddo !j
+
+ ispec = ispec + 1
+ if(MOVIE_COARSE) then
+ ielm = ispec-1
+ else
+ ielm = (NGLLX-1)*(NGLLY-1)*(ispec-1)
+ endif
+ do j = 1,NGLLY-NIT
+ do i = 1,NGLLX-NIT
+ if(MOVIE_COARSE) then
+ ieoff = ielm+1
+ else
+ ieoff = (ielm+(i-1)+(j-1)*(NGLLX-1))+1
+ endif
+
+! for movie_coarse e.g. x(i,j) is defined at x(1,1), x(1,NGLLY), x(NGLLX,1) and x(NGLLX,NGLLY)
+! be aware that for the cubed sphere, the mapping changes for different chunks,
+! i.e. e.g. x(1,1) and x(5,5) flip left and right sides of the elements in geographical coordinates
+ if(MOVIE_COARSE) then
+ if(NCHUNKS == 6) then
+ ! chunks mapped such that element corners increase in long/lat
+ select case (iproc/NPROC+1)
+ case(CHUNK_AB)
+ xp(ieoff) = dble(x(1,NGLLY))
+ yp(ieoff) = dble(y(1,NGLLY))
+ zp(ieoff) = dble(z(1,NGLLY))
+ field_display(ieoff) = dble(displn(1,NGLLY))
+ case(CHUNK_AB_ANTIPODE)
+ xp(ieoff) = dble(x(1,1))
+ yp(ieoff) = dble(y(1,1))
+ zp(ieoff) = dble(z(1,1))
+ field_display(ieoff) = dble(displn(1,1))
+ case(CHUNK_AC)
+ xp(ieoff) = dble(x(1,NGLLY))
+ yp(ieoff) = dble(y(1,NGLLY))
+ zp(ieoff) = dble(z(1,NGLLY))
+ field_display(ieoff) = dble(displn(1,NGLLY))
+ case(CHUNK_AC_ANTIPODE)
+ xp(ieoff) = dble(x(1,1))
+ yp(ieoff) = dble(y(1,1))
+ zp(ieoff) = dble(z(1,1))
+ field_display(ieoff) = dble(displn(1,1))
+ case(CHUNK_BC)
+ xp(ieoff) = dble(x(1,NGLLY))
+ yp(ieoff) = dble(y(1,NGLLY))
+ zp(ieoff) = dble(z(1,NGLLY))
+ field_display(ieoff) = dble(displn(1,NGLLY))
+ case(CHUNK_BC_ANTIPODE)
+ xp(ieoff) = dble(x(NGLLX,NGLLY))
+ yp(ieoff) = dble(y(NGLLX,NGLLY))
+ zp(ieoff) = dble(z(NGLLX,NGLLY))
+ field_display(ieoff) = dble(displn(NGLLX,NGLLY))
+ case default
+ stop 'incorrect chunk number'
+ end select
+ else
+ xp(ieoff) = dble(x(1,1))
+ yp(ieoff) = dble(y(1,1))
+ zp(ieoff) = dble(z(1,1))
+ field_display(ieoff) = dble(displn(1,1))
+ endif ! NCHUNKS
+ else
+ xp(ieoff) = dble(x(i,j))
+ yp(ieoff) = dble(y(i,j))
+ zp(ieoff) = dble(z(i,j))
+ field_display(ieoff) = dble(displn(i,j))
+ endif ! MOVIE_COARSE
+
+ enddo !i
+ enddo !j
+
+ enddo !ispec
+
+ enddo !nproc
+
+ ! compute min and max of data value to normalize
+ min_field_current = minval(field_display(:))
+ max_field_current = maxval(field_display(:))
+
+ ! print minimum and maximum amplitude in current snapshot
+ print *
+ print *,'minimum amplitude in current snapshot = ',min_field_current
+ print *,'maximum amplitude in current snapshot = ',max_field_current
+
+ ! takes average over last few snapshots available and uses it
+ ! to normalize field values
+ if( USE_AVERAGED_MAXIMUM ) then
+
+ ! (average) maximum between positive and negative values
+ max_absol = (abs(min_field_current)+abs(max_field_current))/2.0
+
+ ! stores last few maxima
+ ! index between 1 and nmax_history
+ imax = mod(iframe-1,nmax_history) + 1
+ max_history( imax ) = max_absol
+
+ ! average over history
+ max_average = sum( max_history )
+ if( iframe < nmax_history ) then
+ ! history not filled yet, only average over available entries
+ max_average = max_average / iframe
+ else
+ ! average over all history entries
+ max_average = max_average / nmax_history
+ endif
+
+ print *,'maximum amplitude over averaged last snapshots = ',max_average
+
+ ! scales field values up to match average
+ if( abs(max_absol) > TINYVAL) &
+ field_display = field_display * max_average / max_absol
+
+ ! thresholds positive & negative maximum values
+ where( field_display(:) > max_average ) field_display = max_average
+ where( field_display(:) < - max_average ) field_display = -max_average
+
+ ! normalizes field values
+ if( NORMALIZE_VALUES ) then
+ if( abs(max_average) > TINYVAL ) field_display = field_display / max_average
+ endif
+
+ endif
+
+ print *
+ print *,'initial number of points (with multiples) was ',npointot
+ print *,'final number of points is ',ieoff
+
+ !--- ****** create GMT file ******
+
+ ! create file name and open file
+ if(OUTPUT_BINARY) then
+ if(USE_COMPONENT == 1) then
+ write(outputname,"('bin_movie_',i6.6,'.d')") it
+ elseif(USE_COMPONENT == 2) then
+ write(outputname,"('bin_movie_',i6.6,'.N')") it
+ elseif(USE_COMPONENT == 3) then
+ write(outputname,"('bin_movie_',i6.6,'.E')") it
+ endif
+ open(unit=11,file='OUTPUT_FILES/'//trim(outputname),status='unknown',form='unformatted')
+ if(iframe == 1) open(unit=12,file='OUTPUT_FILES/bin_movie.xy',status='unknown',form='unformatted')
+ else
+ if(USE_COMPONENT == 1) then
+ write(outputname,"('ascii_movie_',i6.6,'.d')") it
+ elseif(USE_COMPONENT == 2) then
+ write(outputname,"('ascii_movie_',i6.6,'.N')") it
+ elseif(USE_COMPONENT == 3) then
+ write(outputname,"('ascii_movie_',i6.6,'.E')") it
+ endif
+ open(unit=11,file='OUTPUT_FILES/'//trim(outputname),status='unknown')
+ if(iframe == 1) open(unit=12,file='OUTPUT_FILES/ascii_movie.xy',status='unknown')
+ endif
+ ! clear number of elements kept
+ ispec = 0
+
+ ! read points for all the slices
+ print *,'Writing output',outputname
+ do iproc = 0,NPROCTOT-1
+
+ ! reset point number
+ ipoin = 0
+
+ do ispecloc = 1,NEX_PER_PROC_XI*NEX_PER_PROC_ETA
+ ispec = ispec + 1
+ if(MOVIE_COARSE) then
+ ielm = ispec - 1
+ else
+ ielm = (NGLLX-1)*(NGLLY-1)*(ispec-1)
+ endif
+
+ do j = 1,NGLLY-NIT
+ do i = 1,NGLLX-NIT
+ if(MOVIE_COARSE) then
+ ieoff = ielm + 1
+ else
+ ieoff = (ielm+(i-1)+(j-1)*(NGLLX-1))+1
+ endif
+
+ ! point position
+ if(iframe == 1) then
+ ! gets cartesian coordinates
+ xcoord = sngl(xp(ieoff))
+ ycoord = sngl(yp(ieoff))
+ zcoord = sngl(zp(ieoff))
+
+ ! location latitude/longitude (with geocentric colatitude theta )
+ call xyz_2_rthetaphi(xcoord,ycoord,zcoord,rval,thetaval,phival)
+
+ ! converts the geocentric colatitude to a geographic colatitude
+ if(.not. ASSUME_PERFECT_SPHERE) then
+ thetaval = PI/2.0d0 - &
+ datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dble(sin(thetaval))))
+ endif
+
+ ! gets geographic latitude and longitude in degrees
+ lat = sngl(90.d0 - thetaval*180.0/PI)
+ long = sngl(phival*180.0/PI)
+ if(long > 180.0) long = long-360.0
+ endif
+
+ ! displacement
+ disp = sngl(field_display(ieoff))
+
+ ! writes displacement and latitude/longitude to corresponding files
+ if(OUTPUT_BINARY) then
+ write(11) disp
+ if(iframe == 1) write(12) long,lat
+ else
+ write(11,*) disp
+ if(iframe == 1) write(12,*) long,lat
+ endif
+
+ enddo !i
+ enddo !j
+ enddo !ispecloc
+ enddo !iproc
+ close(11)
+ if(iframe == 1) close(12)
+
+
+! end of loop and test on all the time steps for all the movie images
+ endif
+ enddo
+
+ print *,'done creating movie'
+ print *,'GMT ascii files are stored in ascii_movie_*.{xy,d,E,N}'
+ print *,'binary files are stored in bin_movie_*.{xy,d,E,N}'
+
+ end program create_movie_GMT_global
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_name_database.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_name_database.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_name_database.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_name_database.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/create_regions_mesh.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_regions_mesh.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_regions_mesh.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_regions_mesh.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1114 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_regions_mesh(iregion_code,ibool,idoubling,is_on_a_slice_edge, &
+ xstore,ystore,zstore,rmins,rmaxs, &
+ iproc_xi,iproc_eta,ichunk,nspec,nspec_tiso, &
+ volume_local,area_local_bottom,area_local_top, &
+ nglob_theor,npointot, &
+ NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE, &
+ NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+ myrank,LOCAL_PATH,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,&
+ SAVE_MESH_FILES,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
+ R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
+ 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,ipass,ratio_divide_central_cube,&
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta)
+
+! creates the different regions of the mesh
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ ! 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 :: offset_proc_xi,offset_proc_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 :: ner_without_doubling,ilayer,ilayer_loop, &
+ ifirst_region,ilast_region,ratio_divide_central_cube
+ integer, dimension(:), allocatable :: perm_layer
+
+ ! correct number of spectral elements in each block depending on chunk type
+ integer nspec,nspec_tiso,nspec_stacey,nspec_actually,nspec_att
+
+ integer NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS
+
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
+
+ integer NPROC_XI,NPROC_ETA
+
+ integer npointot
+
+ logical SAVE_MESH_FILES
+
+ logical INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
+
+ double precision R_CENTRAL_CUBE,RICB,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ RMOHO_FICTITIOUS_IN_MESHER
+
+ double precision RHO_OCEANS
+
+ character(len=150) LOCAL_PATH,errmsg
+
+ ! 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
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ ! 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
+
+ integer, dimension(nspec) :: idoubling
+
+! this for non blocking MPI
+ logical, dimension(nspec) :: is_on_a_slice_edge
+
+ ! parameters needed to store the radii of the grid points in the spherically symmetric Earth
+ double precision rmin,rmax
+
+ ! for model density and anisotropy
+ integer nspec_ani
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,dvpstore, &
+ 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
+
+ ! arrays with mesh parameters
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+ ! proc numbers for MPI
+ integer myrank
+
+ ! check area and volume of the final mesh
+ 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
+
+ ! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
+
+ ! mass matrix and bathymetry for ocean load
+ integer nglob_oceans
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
+
+ ! boundary parameters locator
+ integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax, &
+ ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top
+
+ ! 2-D jacobians and normals
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
+ jacobian2D_xmin,jacobian2D_xmax, &
+ jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom,jacobian2D_top
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_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,ispec
+ 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 :: USE_ONE_LAYER_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 :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
+
+ ! now perform two passes in this part to be able to save memory
+ integer :: ipass
+
+ logical :: ACTUALLY_STORE_ARRAYS
+
+ ! Boundary Mesh
+ integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,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
+
+ ! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+
+ ! New Attenuation definition on all GLL points
+ ! Attenuation
+ if (ATTENUATION) then
+ T_c_source = AM_V%QT_c_source
+ tau_s(:) = AM_V%Qtau_s(:)
+ nspec_att = nspec
+ else
+ nspec_att = 1
+ end if
+ allocate(Qmu_store(NGLLX,NGLLY,NGLLZ,nspec_att))
+ allocate(tau_e_store(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att))
+
+ ! 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))
+
+ ! 2D shape functions and their derivatives
+ allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ))
+ allocate(shape2D_y(NGNOD2D,NGLLX,NGLLZ))
+ allocate(shape2D_bottom(NGNOD2D,NGLLX,NGLLY))
+ allocate(shape2D_top(NGNOD2D,NGLLX,NGLLY))
+ allocate(dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ))
+ allocate(dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ))
+ allocate(dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY))
+ allocate(dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY))
+
+ ! array with model density
+ allocate(rhostore(NGLLX,NGLLY,NGLLZ,nspec))
+ allocate(dvpstore(NGLLX,NGLLY,NGLLZ,nspec))
+
+ ! for anisotropy
+ allocate(kappavstore(NGLLX,NGLLY,NGLLZ,nspec))
+ allocate(muvstore(NGLLX,NGLLY,NGLLZ,nspec))
+
+ allocate(kappahstore(NGLLX,NGLLY,NGLLZ,nspec))
+ allocate(muhstore(NGLLX,NGLLY,NGLLZ,nspec))
+ allocate(eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec))
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS /= 6) then
+ nspec_stacey = nspec
+ else
+ nspec_stacey = 1
+ endif
+ allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey))
+ allocate(rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey))
+
+ ! anisotropy
+ if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
+ (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) then
+ nspec_ani = nspec
+ else
+ nspec_ani = 1
+ endif
+ allocate(c11store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c12store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c13store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c14store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c15store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c16store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c22store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c23store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c24store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c25store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c26store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c33store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c34store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c35store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c36store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c44store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c45store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c46store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c55store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c56store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ allocate(c66store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+
+ ! boundary locator
+ allocate(iboun(6,nspec))
+
+ ! boundary parameters locator
+ allocate(ibelm_xmin(NSPEC2DMAX_XMIN_XMAX))
+ allocate(ibelm_xmax(NSPEC2DMAX_XMIN_XMAX))
+ allocate(ibelm_ymin(NSPEC2DMAX_YMIN_YMAX))
+ allocate(ibelm_ymax(NSPEC2DMAX_YMIN_YMAX))
+ allocate(ibelm_bottom(NSPEC2D_BOTTOM))
+ allocate(ibelm_top(NSPEC2D_TOP))
+
+ ! 2-D jacobians and normals
+ allocate(jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX))
+ allocate(jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX))
+ allocate(jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX))
+ allocate(jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX))
+ allocate(jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM))
+ allocate(jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP))
+
+ allocate(normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX))
+ allocate(normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX))
+ allocate(normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX))
+ allocate(normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX))
+ allocate(normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM))
+ allocate(normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP))
+
+ ! Stacey
+ allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX))
+ allocate(nimax(2,NSPEC2DMAX_YMIN_YMAX))
+ allocate(njmin(2,NSPEC2DMAX_XMIN_XMAX))
+ allocate(njmax(2,NSPEC2DMAX_XMIN_XMAX))
+ allocate(nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX))
+ allocate(nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX))
+
+ ! MPI cut-planes parameters along xi and along eta
+ allocate(iMPIcut_xi(2,nspec))
+ allocate(iMPIcut_eta(2,nspec))
+
+ ! store and save the final arrays only in the second pass
+ ! therefore in the first pass some arrays can be allocated with a dummy size
+ if(ipass == 1) then
+ ACTUALLY_STORE_ARRAYS = .false.
+ nspec_actually = 1
+ else
+ ACTUALLY_STORE_ARRAYS = .true.
+ nspec_actually = nspec
+ endif
+ allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(xiystore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(xizstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(etaxstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(etaystore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(etazstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(gammaxstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(gammaystore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(gammazstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier); if(ier /= 0) stop 'error in allocate'
+
+ ! boundary mesh
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ NSPEC2D_MOHO = NSPEC2D_TOP
+ NSPEC2D_400 = NSPEC2D_MOHO / 4
+ NSPEC2D_670 = NSPEC2D_400
+ else
+ NSPEC2D_MOHO = 1
+ NSPEC2D_400 = 1
+ NSPEC2D_670 = 1
+ endif
+ allocate(ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO))
+ allocate(ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400))
+ allocate(ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670))
+ allocate(normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO))
+ allocate(normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400))
+ allocate(normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670))
+ allocate(jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO))
+ allocate(jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400))
+ allocate(jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670))
+
+ ! initialize number of layers
+ call crm_initialize_layers(myrank,ipass,xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ iaddx,iaddy,iaddz,nspec,xstore,ystore,zstore,ibool,idoubling, &
+ iboun,iMPIcut_xi,iMPIcut_eta,ispec2D_moho_top,ispec2D_moho_bot, &
+ ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
+ NEX_PER_PROC_ETA,nex_eta_moho,RMOHO,R400,R670,r_moho,r_400,r_670, &
+ ONE_CRUST,NUMBER_OF_MESH_LAYERS,layer_shift, &
+ iregion_code,ifirst_region,ilast_region, &
+ first_layer_aniso,last_layer_aniso,nb_layer_above_aniso,is_on_a_slice_edge)
+
+ ! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
+ allocate (perm_layer(ifirst_region:ilast_region))
+ 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
+
+ ! crustal layer stretching: element layer's top and bottom radii will get stretched when in crust
+ ! (number of element layers in crust can vary for different resolutions and 1chunk simulations)
+ allocate(stretch_tab(2,ner(1)))
+ if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
+ ! stretching function determines top and bottom of each element layer in the
+ ! crust region (between r_top(1) and r_bottom(1)), where ner(1) is the
+ ! number of element layers in this crust region
+
+ ! differentiate between regional meshes or global meshes
+ if( REGIONAL_MOHO_MESH ) then
+ call stretching_function_regional(r_top(1),r_bottom(1),ner(1),stretch_tab)
+ else
+ call stretching_function(r_top(1),r_bottom(1),ner(1),stretch_tab)
+ endif
+
+ ! RMIDDLE_CRUST so far is only used for 1D - models with two layers in the crust
+ ! (i.e. ONE_CRUST is set to .false.), those models do not use CASE_3D
+
+ ! all 3D models use this stretching function to honor a 3D crustal model
+ ! for those models, we set RMIDDLE_CRUST to the bottom of the first element layer
+ ! this value will be used in moho_stretching.f90 to decide whether or not elements
+ ! have to be stretched under oceanic crust.
+ !
+ ! note: stretch_tab uses (dimensionalized) radii from r_top and r_bottom
+ !(with stretch_tab( index_radius(1=top,2=bottom), index_layer( 1=first layer, 2=second layer, 3= ...) )
+ RMIDDLE_CRUST = stretch_tab(2,1)
+
+ endif
+
+!----
+!---- creates mesh elements
+!----
+
+ ! loop on all the layers in this region of the mesh
+ ispec = 0 ! counts all the elements 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
+ call create_regular_elements(myrank,ilayer,ichunk,ispec,ipass, &
+ ifirst_region,ilast_region,iregion_code, &
+ nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ ner_without_doubling,ner,ratio_sampling_array,r_top,r_bottom, &
+ xstore,ystore,zstore, &
+ iaddx,iaddy,iaddz,xigll,yigll,zigll, &
+ shape3D,dershape2D_bottom, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ rmin,rmax,r_moho,r_400,r_670, &
+ rhostore,dvpstore,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, &
+ nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore,&
+ nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
+ rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB, &
+ stretch_tab,ACTUALLY_STORE_ARRAYS, &
+ NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
+ 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)
+
+
+ ! mesh doubling elements
+ if( this_region_has_a_doubling(ilayer) ) &
+ call create_doubling_elements(myrank,ilayer,ichunk,ispec,ipass, &
+ ifirst_region,ilast_region,iregion_code, &
+ nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ ner,ratio_sampling_array,r_top,r_bottom, &
+ xstore,ystore,zstore,xigll,yigll,zigll, &
+ shape3D,dershape2D_bottom, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ rmin,rmax,r_moho,r_400,r_670, &
+ rhostore,dvpstore,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, &
+ nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore,&
+ nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
+ rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB,ACTUALLY_STORE_ARRAYS, &
+ NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
+ 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, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta)
+
+ enddo !ilayer_loop
+
+ ! define central cube in inner core
+ if(INCLUDE_CENTRAL_CUBE .and. iregion_code == IREGION_INNER_CORE) &
+ call create_central_cube(myrank,ichunk,ispec,iaddx,iaddy,iaddz, &
+ nspec,NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,R_CENTRAL_CUBE, &
+ iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,ratio_divide_central_cube, &
+ iMPIcut_xi,iMPIcut_eta,iboun, &
+ idoubling,iregion_code,xstore,ystore,zstore, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME,&
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ shape3D,rmin,rmax,rhostore,dvpstore,&
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore,nspec_actually, &
+ 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
+ rho_vp,rho_vs,ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS,xigll,yigll,zigll)
+
+
+ ! check total number of spectral elements created
+ if(ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec')
+
+! if any of these flags is true, the element is on a communication edge
+! this is not enough because it can also be in contact by an edge or a corner but not a full face
+! therefore we will have to fix array "is_on_a_slice_edge" later in the solver to take this into account
+ is_on_a_slice_edge(:) = &
+ iMPIcut_xi(1,:) .or. iMPIcut_xi(2,:) .or. &
+ iMPIcut_eta(1,:) .or. iMPIcut_eta(2,:) .or. &
+ iboun(1,:) .or. iboun(2,:) .or. &
+ iboun(3,:) .or. iboun(4,:) .or. &
+ iboun(5,:) .or. iboun(6,:)
+
+! no need to count fictitious elements on the edges
+! for which communications cannot be overlapped with calculations
+ where(idoubling == IFLAG_IN_FICTITIOUS_CUBE) is_on_a_slice_edge = .false.
+
+ ! only create global addressing and the MPI buffers in the first pass
+ if(ipass == 1) then
+
+ !uncomment: adds model smoothing for point profile models
+ ! if( THREE_D_MODEL == THREE_D_MODEL_PPM ) then
+ ! call smooth_model(myrank, nproc_xi,nproc_eta,&
+ ! rho_vp,rho_vs,nspec_stacey, &
+ ! iregion_code,xixstore,xiystore,xizstore, &
+ ! etaxstore,etaystore,etazstore, &
+ ! gammaxstore,gammaystore,gammazstore, &
+ ! xstore,ystore,zstore,rhostore,dvpstore, &
+ ! kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
+ ! nspec,HETEROGEN_3D_MANTLE, &
+ ! NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
+
+ ! allocate memory for arrays
+ allocate(locval(npointot),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(ifseg(npointot),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(xp(npointot),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(yp(npointot),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(zp(npointot),stat=ier); if(ier /= 0) stop 'error in allocate'
+
+ 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) stop 'error in deallocate'
+ deallocate(yp,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(zp,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+ ! 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')
+
+ ! creates a new indirect addressing to reduce cache misses in memory access in the solver
+ ! this is *critical* to improve performance in the solver
+ call get_global_indirect_addressing(nspec,nglob,ibool)
+
+ ! checks again
+ 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,prname,nspec,iMPIcut_xi,ibool, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC2D_ETA_FACE,iregion_code)
+
+ call get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC2D_XI_FACE,iregion_code)
+
+ call get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool,idoubling, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion_code)
+
+ ! Stacey
+ if(NCHUNKS /= 6) &
+ call get_absorb(myrank,prname,iboun,nspec,nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
+
+ ! create AVS or DX mesh data for the slices
+ if(SAVE_MESH_FILES) then
+ call write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
+
+ call write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
+ idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
+ rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
+
+ call write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun,ibool, &
+ idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
+ rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
+
+ call write_AVS_DX_surface_data(myrank,prname,nspec,iboun,ibool, &
+ idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
+ rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
+
+ !> Hejun
+ ! Output material information for all GLL points
+ ! Can be use to check the mesh
+ ! call write_AVS_DX_global_data_gll(prname,nspec,xstore,ystore,zstore,&
+ ! rhostore,kappavstore,muvstore,Qmu_store,ATTENUATION)
+ endif
+
+ deallocate(locval,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(ifseg,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+! 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
+ nspec_tiso = count(idoubling(1:nspec) == IFLAG_220_80) + count(idoubling(1:nspec) == IFLAG_80_MOHO)
+
+ 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,&
+ xigll,yigll,zigll)
+
+ ! allocates mass matrix in this slice (will be fully assembled in the solver)
+ allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ ! allocates ocean load mass matrix as well if oceans
+ if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
+ nglob_oceans = nglob
+ else
+ ! allocate dummy array if no oceans
+ nglob_oceans = 1
+ endif
+ allocate(rmass_ocean_load(nglob_oceans))
+
+ ! creating mass matrix in this slice (will be fully assembled in the solver)
+ call create_mass_matrices(myrank,nspec,idoubling,wxgll,wygll,wzgll,ibool, &
+ nspec_actually,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ iregion_code,nglob,rmass,rhostore,kappavstore, &
+ nglob_oceans,rmass_ocean_load,NSPEC2D_TOP,ibelm_top,jacobian2D_top, &
+ xstore,ystore,zstore,RHO_OCEANS)
+
+ ! save the binary files
+ 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,dvpstore, &
+ 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,is_on_a_slice_edge,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,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,OCEANS, &
+ tau_s,tau_e_store,Qmu_store,T_c_source,ATTENUATION, &
+ size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5),&
+ ABSORBING_CONDITIONS,SAVE_MESH_FILES)
+
+ deallocate(rmass,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(rmass_ocean_load,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+ ! 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)
+ endif
+
+ ! compute volume, bottom and top area of that part of the slice
+ call crm_compute_volumes(volume_local,area_local_bottom,area_local_top, &
+ nspec,wxgll,wygll,wzgll,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ NSPEC2D_BOTTOM,jacobian2D_bottom,NSPEC2D_TOP,jacobian2D_top)
+
+
+ else
+ stop 'there cannot be more than two passes in mesh creation'
+
+ endif ! end of test if first or second pass
+
+ deallocate(stretch_tab)
+ deallocate(perm_layer)
+
+ ! deallocate these arrays after each pass because they have a different size in each pass to save memory
+ deallocate(xixstore,xiystore,xizstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(etaxstore,etaystore,etazstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(gammaxstore,gammaystore,gammazstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+ ! deallocate arrays
+ deallocate(rhostore,dvpstore,kappavstore,kappahstore)
+ deallocate(muvstore,muhstore)
+ deallocate(eta_anisostore)
+ deallocate(c11store)
+ deallocate(c12store)
+ deallocate(c13store)
+ deallocate(c14store)
+ deallocate(c15store)
+ deallocate(c16store)
+ deallocate(c22store)
+ deallocate(c23store)
+ deallocate(c24store)
+ deallocate(c25store)
+ deallocate(c26store)
+ deallocate(c33store)
+ deallocate(c34store)
+ deallocate(c35store)
+ deallocate(c36store)
+ deallocate(c44store)
+ deallocate(c45store)
+ deallocate(c46store)
+ deallocate(c55store)
+ deallocate(c56store)
+ deallocate(c66store)
+ deallocate(iboun)
+ deallocate(xigll,yigll,zigll)
+ deallocate(wxgll,wygll,wzgll)
+ deallocate(shape3D,dershape3D)
+ deallocate(shape2D_x,shape2D_y,shape2D_bottom,shape2D_top)
+ deallocate(dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top)
+ deallocate(ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax)
+ deallocate(ibelm_bottom,ibelm_top)
+ deallocate(jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax)
+ deallocate(jacobian2D_bottom,jacobian2D_top)
+ deallocate(normal_xmin,normal_xmax,normal_ymin,normal_ymax)
+ deallocate(normal_bottom,normal_top)
+ deallocate(iMPIcut_xi,iMPIcut_eta)
+ deallocate(nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta)
+ deallocate(rho_vp,rho_vs)
+ deallocate(Qmu_store)
+ deallocate(tau_e_store)
+ deallocate(ibelm_moho_top,ibelm_moho_bot)
+ deallocate(ibelm_400_top,ibelm_400_bot)
+ deallocate(ibelm_670_top,ibelm_670_bot)
+ deallocate(normal_moho,normal_400,normal_670)
+ deallocate(jacobian2D_moho,jacobian2D_400,jacobian2D_670)
+
+ end subroutine create_regions_mesh
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine crm_initialize_layers(myrank,ipass,xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ iaddx,iaddy,iaddz,nspec,xstore,ystore,zstore,ibool,idoubling, &
+ iboun,iMPIcut_xi,iMPIcut_eta,ispec2D_moho_top,ispec2D_moho_bot, &
+ ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
+ NEX_PER_PROC_ETA,nex_eta_moho,RMOHO,R400,R670,r_moho,r_400,r_670, &
+ ONE_CRUST,NUMBER_OF_MESH_LAYERS,layer_shift, &
+ iregion_code,ifirst_region,ilast_region, &
+ first_layer_aniso,last_layer_aniso,nb_layer_above_aniso,is_on_a_slice_edge)
+
+! create the different regions of the mesh
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: myrank,ipass
+
+ double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
+ double precision wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
+
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ double precision shape2D_x(NGNOD2D,NGLLY,NGLLZ),shape2D_y(NGNOD2D,NGLLX,NGLLZ)
+ double precision shape2D_bottom(NGNOD2D,NGLLX,NGLLY),shape2D_top(NGNOD2D,NGLLX,NGLLY)
+ double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
+ double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+
+ integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
+
+ integer nspec
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer idoubling(nspec)
+
+ logical iboun(6,nspec)
+ logical iMPIcut_xi(2,nspec),iMPIcut_eta(2,nspec)
+
+ integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot, &
+ ispec2D_670_top,ispec2D_670_bot
+ integer NEX_PER_PROC_ETA,nex_eta_moho
+ double precision RMOHO,R400,R670
+ double precision r_moho,r_400,r_670
+
+ logical ONE_CRUST
+ integer NUMBER_OF_MESH_LAYERS,layer_shift
+
+ ! code for the four regions of the mesh
+ integer iregion_code,ifirst_region,ilast_region
+ integer first_layer_aniso,last_layer_aniso,nb_layer_above_aniso
+
+! this for non blocking MPI
+ logical, dimension(nspec) :: is_on_a_slice_edge
+
+! 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)
+
+! 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
+
+! sets number of layers
+ 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
+
+! initialize mesh arrays
+ 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.
+ is_on_a_slice_edge(:) = .false.
+
+ ! boundary mesh
+ 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
+
+ end subroutine crm_initialize_layers
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine crm_compute_volumes(volume_local,area_local_bottom,area_local_top, &
+ nspec,wxgll,wygll,wzgll,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ NSPEC2D_BOTTOM,jacobian2D_bottom,NSPEC2D_TOP,jacobian2D_top)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: volume_local,area_local_bottom,area_local_top
+
+ integer :: nspec
+ double precision :: wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+ integer :: NSPEC2D_BOTTOM,NSPEC2D_TOP
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP) :: jacobian2D_top
+
+ ! local parameters
+ double precision :: weight
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ integer :: i,j,k,ispec
+
+ ! initializes
+ 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
+ xixl = xixstore(i,j,k,ispec)
+ xiyl = xiystore(i,j,k,ispec)
+ xizl = xizstore(i,j,k,ispec)
+ etaxl = etaxstore(i,j,k,ispec)
+ etayl = etaystore(i,j,k,ispec)
+ etazl = etazstore(i,j,k,ispec)
+ gammaxl = gammaxstore(i,j,k,ispec)
+ gammayl = gammaystore(i,j,k,ispec)
+ gammazl = gammazstore(i,j,k,ispec)
+
+ 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
+
+ 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
+
+
+ end subroutine crm_compute_volumes
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_regular_elements.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_regular_elements.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_regular_elements.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_regular_elements.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,287 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_regular_elements(myrank,ilayer,ichunk,ispec,ipass, &
+ ifirst_region,ilast_region,iregion_code, &
+ nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ ner_without_doubling,ner,ratio_sampling_array,r_top,r_bottom, &
+ xstore,ystore,zstore, &
+ iaddx,iaddy,iaddz,xigll,yigll,zigll, &
+ shape3D,dershape2D_bottom, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ rmin,rmax,r_moho,r_400,r_670, &
+ rhostore,dvpstore,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, &
+ nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore,&
+ nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
+ rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB, &
+ stretch_tab,ACTUALLY_STORE_ARRAYS, &
+ NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
+ 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)
+
+
+! adds a regular spectral element to the different regions of the mesh
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer :: myrank,ilayer,ichunk,ispec,ipass,ifirst_region,ilast_region
+ ! code for the four regions of the mesh
+ integer iregion_code
+ ! correct number of spectral elements in each block depending on chunk type
+ integer nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS
+ integer NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
+
+ integer :: ner_without_doubling
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+
+! 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)
+
+! topology of the elements
+ integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
+
+! Gauss-Lobatto-Legendre points and weights of integration
+ double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
+
+! 3D shape functions and their derivatives
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+
+! 2D shape functions and their derivatives
+ double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+
+ logical INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
+
+ double precision RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+! parameters needed to store the radii of the grid points in the spherically symmetric Earth
+ double precision rmin,rmax
+ double precision r_moho,r_400,r_670
+
+! for model density and anisotropy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ integer nspec_ani
+ 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
+
+! arrays with mesh parameters
+ integer nspec_actually
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+! Stacey, indices for Clayton-Engquist absorbing conditions
+ integer nspec_stacey
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
+
+! boundary locator
+ logical iboun(6,nspec)
+
+! MPI cut-planes parameters along xi and along eta
+ logical, dimension(2,nspec) :: iMPIcut_xi,iMPIcut_eta
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+ integer iproc_xi,iproc_eta
+
+! attenuation
+ integer nspec_att
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
+ double precision, dimension(N_SLS) :: tau_s
+ double precision T_c_source
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+ integer idoubling(nspec)
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ logical :: USE_ONE_LAYER_SB
+
+ double precision, dimension(2,ner(1)) :: stretch_tab
+
+ logical :: ACTUALLY_STORE_ARRAYS
+
+! Boundary Mesh
+ integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
+ integer ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO)
+ integer ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400)
+ integer ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670)
+ real(kind=CUSTOM_REAL) normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO)
+ real(kind=CUSTOM_REAL) normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400)
+ real(kind=CUSTOM_REAL) normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670)
+ real(kind=CUSTOM_REAL) jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO)
+ real(kind=CUSTOM_REAL) jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400)
+ real(kind=CUSTOM_REAL) jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670)
+
+ integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top, &
+ ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot
+
+ ! local parameters
+ double precision, dimension(NGNOD) :: offset_x,offset_y,offset_z
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm
+ double precision :: r1,r2,r3,r4,r5,r6,r7,r8
+ integer :: ix_elem,iy_elem,iz_elem,ignod,ispec_superbrick
+ logical :: is_superbrick
+
+ ! 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
+ 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)*xelm(1)+yelm(1)**2+zelm(1)**2)
+ r2=sqrt(xelm(2)*xelm(2)+yelm(2)**2+zelm(2)**2)
+ r3=sqrt(xelm(3)*xelm(3)+yelm(3)**2+zelm(3)**2)
+ r4=sqrt(xelm(4)*xelm(4)+yelm(4)**2+zelm(4)**2)
+ r5=sqrt(xelm(5)*xelm(5)+yelm(5)**2+zelm(5)**2)
+ r6=sqrt(xelm(6)*xelm(6)+yelm(6)**2+zelm(6)**2)
+ r7=sqrt(xelm(7)*xelm(7)+yelm(7)**2+zelm(7)**2)
+ r8=sqrt(xelm(8)*xelm(8)+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,myrank,ABSORBING_CONDITIONS, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,nspec_actually, &
+ 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,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
+ rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
+ xigll,yigll,zigll)
+
+ ! 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
+
+ end subroutine create_regular_elements
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_serial_name_database.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/create_serial_name_database.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_serial_name_database.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_serial_name_database.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_serial_name_database(prname,iproc,iregion_code, &
+ LOCAL_PATH,NPROCTOT,OUTPUT_FILES)
+
+! create name of the database for serial codes (AVS_DX and codes to check buffers)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iproc,iregion_code,NPROCTOT
+
+! name of the database file
+ character(len=150) prname,procname,base_path,serial_prefix, &
+ LOCAL_PATH,OUTPUT_FILES
+
+ integer iprocloop
+ integer, dimension(:), allocatable :: num_active_proc
+
+! create the name for the database of the current slide and region
+ write(procname,"('/proc',i6.6,'_reg',i1,'_')") iproc,iregion_code
+
+! on a machine with local disks, path on frontend can be different from local paths
+ if(.not. LOCAL_PATH_IS_ALSO_GLOBAL) then
+
+! allocate array for active processors
+ allocate(num_active_proc(0:NPROCTOT-1))
+
+! read filtered file with name of active machines
+ open(unit=48,file=trim(OUTPUT_FILES)//'/filtered_machines.txt',status='old',action='read')
+ do iprocloop = 0,NPROCTOT-1
+ read(48,*) num_active_proc(iprocloop)
+ enddo
+ close(48)
+
+! create the serial prefix pointing to the correct machine
+ write(serial_prefix,"('/auto/scratch_n',i6.6,'/')") num_active_proc(iproc)
+
+! suppress everything until the last "/" to define the base name of local path
+! this is system dependent since it assumes the disks are mounted remotely
+ base_path = LOCAL_PATH(index(LOCAL_PATH,'/',.true.)+1:len_trim(LOCAL_PATH))
+
+! create full name with path
+ prname = trim(serial_prefix) // trim(base_path) // procname
+
+! deallocate array
+ deallocate(num_active_proc)
+
+! on shared-memory machines, global path is the same as local path
+ else
+
+! create full name with path
+ prname = trim(LOCAL_PATH) // procname
+
+ endif
+
+ end subroutine create_serial_name_database
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/define_derivation_matrices.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/define_derivation_matrices.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/define_derivation_matrices.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/define_derivation_matrices.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/define_superbrick.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/define_superbrick.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/define_superbrick.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/define_superbrick.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,2042 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! 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/src/euler_angles.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/euler_angles.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/euler_angles.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/euler_angles.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute the 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/src/exit_mpi.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/exit_mpi.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/exit_mpi.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/exit_mpi.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,107 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! 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
+! note: MPI_ABORT does not return, and does exit the
+! program with an error code of 30
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+
+! otherwise: there is no standard behaviour to exit with an error code in fortran,
+! however most compilers do recognize this as an error code stop statement;
+! to check stop code in terminal: > echo $?
+ stop 30
+
+ ! or just exit with message:
+ !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/src/fix_non_blocking_flags.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/fix_non_blocking_flags.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/fix_non_blocking_flags.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/fix_non_blocking_flags.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! fix the non blocking arrays to assemble the slices inside each chunk: elements
+! in contact with the MPI faces by an edge or a corner only but not
+! a full face are missing, therefore let us add them
+ subroutine fix_non_blocking_slices(is_on_a_slice_edge,iboolright_xi, &
+ iboolleft_xi,iboolright_eta,iboolleft_eta, &
+ npoin2D_xi,npoin2D_eta,ibool, &
+ mask_ibool,nspec,nglob,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,nglob,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
+
+ logical, dimension(nspec) :: is_on_a_slice_edge
+
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ logical, dimension(nglob) :: mask_ibool
+
+ integer :: ipoin,ispec,i,j,k
+
+! clean the mask
+ mask_ibool(:) = .false.
+
+! mark all the points that are in the MPI buffers to assemble inside each chunk
+ do ipoin = 1,npoin2D_xi(1)
+ mask_ibool(iboolleft_xi(ipoin)) = .true.
+ enddo
+
+ do ipoin = 1,npoin2D_eta(1)
+ mask_ibool(iboolleft_eta(ipoin)) = .true.
+ enddo
+
+ do ipoin = 1,npoin2D_xi(2)
+ mask_ibool(iboolright_xi(ipoin)) = .true.
+ enddo
+
+ do ipoin = 1,npoin2D_eta(2)
+ mask_ibool(iboolright_eta(ipoin)) = .true.
+ enddo
+
+! now label all the elements that have at least one corner belonging
+! to any of these buffers as elements that must contribute to the
+! first step of the calculations (performed on the edges before starting
+! the non blocking communications); there is no need to examine the inside
+! of the elements, checking their eight corners is sufficient
+ do ispec = 1,nspec
+ do k = 1,NGLLZ,NGLLZ-1
+ do j = 1,NGLLY,NGLLY-1
+ do i = 1,NGLLX,NGLLX-1
+ if(mask_ibool(ibool(i,j,k,ispec))) then
+ is_on_a_slice_edge(ispec) = .true.
+ goto 888
+ endif
+ enddo
+ enddo
+ enddo
+ 888 continue
+ enddo
+
+ end subroutine fix_non_blocking_slices
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+! fix the non blocking arrays to assemble the central cube: elements
+! in contact with the MPI faces by an edge or a corner only but not
+! a full face are missing, therefore let us add them
+ subroutine fix_non_blocking_central_cube(is_on_a_slice_edge, &
+ ibool,nspec,nglob,nb_msgs_theor_in_cube,ibelm_bottom_inner_core, &
+ idoubling_inner_core,npoin2D_cube_from_slices,ibool_central_cube,NSPEC2D_BOTTOM_INNER_CORE,ichunk)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,nglob,nb_msgs_theor_in_cube,NSPEC2D_BOTTOM_INNER_CORE,ichunk,npoin2D_cube_from_slices
+
+ logical, dimension(nspec) :: is_on_a_slice_edge
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices) :: ibool_central_cube
+
+ integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
+
+! local to global mapping
+ integer, dimension(nspec) :: idoubling_inner_core
+
+! this mask is declared as integer in the calling program because it is used elsewhere
+! to store integers, and it is reused here as a logical to save memory
+ logical, dimension(nglob) :: mask_ibool
+
+ integer :: ipoin,ispec,i,j,k,imsg,ispec2D
+
+ if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
+ do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
+ ispec = ibelm_bottom_inner_core(ispec2D)
+ is_on_a_slice_edge(ispec) = .true.
+ enddo
+ endif
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+ do ispec = 1,nspec
+ if(idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling_inner_core(ispec) == IFLAG_TOP_CENTRAL_CUBE) &
+ is_on_a_slice_edge(ispec) = .true.
+ enddo
+ endif
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+! clean the mask
+ mask_ibool(:) = .false.
+
+ do imsg = 1,nb_msgs_theor_in_cube
+ do ipoin = 1,npoin2D_cube_from_slices
+ mask_ibool(ibool_central_cube(imsg,ipoin)) = .true.
+ enddo
+ enddo
+
+! now label all the elements that have at least one corner belonging
+! to any of these buffers as elements that must contribute to the
+! first step of the calculations (performed on the edges before starting
+! the non blocking communications); there is no need to examine the inside
+! of the elements, checking their eight corners is sufficient
+ do ispec = 1,nspec
+ do k = 1,NGLLZ,NGLLZ-1
+ do j = 1,NGLLY,NGLLY-1
+ do i = 1,NGLLX,NGLLX-1
+ if(mask_ibool(ibool(i,j,k,ispec))) then
+ is_on_a_slice_edge(ispec) = .true.
+ goto 888
+ endif
+ enddo
+ enddo
+ enddo
+ 888 continue
+ enddo
+
+ endif
+
+ end subroutine fix_non_blocking_central_cube
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_1D_buffers.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_1D_buffers.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_1D_buffers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_1D_buffers.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,286 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
+ idoubling,xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion)
+
+! routine to create the MPI 1D chunk buffers for edges
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank,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
+
+! processor identification
+ character(len=150) prname
+
+! 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
+ 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
+ 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
+ ! 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
+ write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+ enddo
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin1D
+
+ 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
+ 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
+ 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
+ ! 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
+ write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+ enddo
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin1D
+
+ 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
+ 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
+ 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
+
+! 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
+ write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+ enddo
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin1D
+
+ 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
+ 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
+ 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
+
+! 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
+ write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+ enddo
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin1D
+
+ 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')
+
+ end subroutine get_MPI_1D_buffers
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_cutplanes_eta.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_eta.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_cutplanes_eta.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_cutplanes_eta.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,168 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_XI_FACE,iregion)
+
+! 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 nspec,myrank,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
+
+! processor identification
+ character(len=150) prname
+
+! 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
+ 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
+ write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin2D_eta
+
+ 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
+ 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
+ write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin2D_eta
+
+ 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')
+
+ end subroutine get_MPI_cutplanes_eta
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_cutplanes_xi.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_xi.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_cutplanes_xi.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_MPI_cutplanes_xi.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_ETA_FACE,iregion)
+
+! 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 nspec,myrank,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
+ integer ier
+
+! processor identification
+ character(len=150) prname,errmsg
+
+! 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
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_xi.txt', &
+ status='unknown',iostat=ier)
+ if( ier /= 0 ) then
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'error creating file: '
+ write(IMAIN,*) prname(1:len_trim(prname))//'iboolleft_xi.txt'
+ write(IMAIN,*)
+ write(IMAIN,*) 'please make sure that the directory specified in Par_file as LOCAL_PATH exists'
+ write(IMAIN,*)
+ endif
+ call exit_mpi(myrank,'error creating iboolleft_xi.txt, please check your Par_file LOCAL_PATH setting')
+ endif
+! 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
+ write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin2D_xi
+
+ 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
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolright_xi.txt', &
+ status='unknown',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error creating iboolright_xi.txt for this process')
+
+! 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
+ write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin2D_xi
+
+ 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
+
+ end subroutine get_MPI_cutplanes_xi
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_absorb.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_absorb.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_absorb.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_absorb.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,144 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_absorb(myrank,prname,iboun,nspec, &
+ nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
+
+! Stacey, define flags for absorbing boundaries
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
+
+ integer nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX)
+ integer njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX)
+ integer nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX)
+
+ logical iboun(6,nspec)
+
+! global element numbering
+ integer ispecg
+
+! counters to keep track of the number of elements on each of the
+! five absorbing boundaries
+ integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5
+
+! processor identification
+ character(len=150) prname
+
+ ispecb1=0
+ ispecb2=0
+ ispecb3=0
+ ispecb4=0
+ ispecb5=0
+
+ do ispecg=1,nspec
+
+! determine if the element falls on an absorbing boundary
+
+ if(iboun(1,ispecg)) then
+
+! on boundary 1: xmin
+ ispecb1=ispecb1+1
+
+! this is useful even if it is constant because it can be zero inside the slices
+ njmin(1,ispecb1)=1
+ njmax(1,ispecb1)=NGLLY
+
+! check for ovelap with other boundaries
+ nkmin_xi(1,ispecb1)=1
+ if(iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2
+ endif
+
+ if(iboun(2,ispecg)) then
+
+! on boundary 2: xmax
+ ispecb2=ispecb2+1
+
+! this is useful even if it is constant because it can be zero inside the slices
+ njmin(2,ispecb2)=1
+ njmax(2,ispecb2)=NGLLY
+
+! check for ovelap with other boundaries
+ nkmin_xi(2,ispecb2)=1
+ if(iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2
+ endif
+
+ if(iboun(3,ispecg)) then
+
+! on boundary 3: ymin
+ ispecb3=ispecb3+1
+
+! check for ovelap with other boundaries
+ nimin(1,ispecb3)=1
+ if(iboun(1,ispecg)) nimin(1,ispecb3)=2
+ nimax(1,ispecb3)=NGLLX
+ if(iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1
+ nkmin_eta(1,ispecb3)=1
+ if(iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2
+ endif
+
+ if(iboun(4,ispecg)) then
+
+! on boundary 4: ymax
+ ispecb4=ispecb4+1
+
+! check for ovelap with other boundaries
+ nimin(2,ispecb4)=1
+ if(iboun(1,ispecg)) nimin(2,ispecb4)=2
+ nimax(2,ispecb4)=NGLLX
+ if(iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1
+ nkmin_eta(2,ispecb4)=1
+ if(iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2
+ endif
+
+! on boundary 5: bottom
+ if(iboun(5,ispecg)) ispecb5=ispecb5+1
+
+ enddo
+
+! check theoretical value of elements at the bottom
+ if(ispecb5 /= NSPEC2D_BOTTOM) &
+ call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM in absorbing boundary detection')
+
+! save these temporary arrays for the solver for Stacey conditions
+ open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin',status='unknown',form='unformatted',action='write')
+ write(27) nimin
+ write(27) nimax
+ write(27) njmin
+ write(27) njmax
+ write(27) nkmin_xi
+ write(27) nkmin_eta
+ close(27)
+
+ end subroutine get_absorb
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_attenuation.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_attenuation.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_attenuation.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_attenuation.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,721 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine 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))//'attenuation.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 get_attenuation_property_values(tau_s, tau_e, fc, omsb)
+
+ factor_common(:,i,j,k,ispec) = fc(:)
+ one_minus_sum_beta(i,j,k,ispec) = omsb
+
+ ! Determine the "scale_factor" from tau_s, tau_e, central source frequency, and Q
+ call get_attenuation_scale_factor(myrank, T_c_source, tau_e, tau_s, Q_mu, sf)
+ scale_factor(i,j,k,ispec) = sf
+ enddo
+ enddo
+ enddo
+ enddo
+
+ end subroutine get_attenuation_model_3D
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+ subroutine get_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 get_attenuation_property_values
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine get_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.8 .or. scale_factor > 1.2) then
+ write(*,*)'scale factor: ', scale_factor
+ call exit_MPI(myrank,'incorrect correction factor in attenuation model')
+ endif
+
+ end subroutine get_attenuation_scale_factor
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine get_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 get_attenuation_memory_values
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+! not used anymore...
+!
+! 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'
+!
+!! model_attenuation_variables
+! type model_attenuation_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
+! integer dummy_pad ! padding 4 bytes to align the structure
+! end type model_attenuation_variables
+!
+! type (model_attenuation_variables) AM_V
+!! model_attenuation_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
+!
+!
+!-------------------------------------------------------------------------------------------------
+!
+!
+!-------------------------------------------------------------------------------------------------
+!
+! not used anymore...
+!
+! 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
+!
+!
+!-------------------------------------------------------------------------------------------------
+!
+! not used anymore...
+!
+! 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
+!
+!
+!-------------------------------------------------------------------------------------------------
+!
+! not used anymore...
+!
+! 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
+!
+!
+!-------------------------------------------------------------------------------------------------
+!
+!
+! not used anymore...
+!
+! 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
+!
+!
+!-------------------------------------------------------------------------------------------------
+!
+! not used anymore...
+!
+! subroutine attenuation_save_arrays(prname, iregion_code, AM_V)
+!
+! implicit none
+!
+! include 'mpif.h'
+! include 'constants.h'
+!
+!! model_attenuation_variables
+! type model_attenuation_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 model_attenuation_variables
+!
+! type (model_attenuation_variables) AM_V
+!! model_attenuation_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
+!
+!
+!-------------------------------------------------------------------------------------------------
+!
+! not used anymore...
+!
+! subroutine get_attenuation_index(iflag, radius, index, inner_core, AM_V)
+!
+! implicit none
+!
+! include 'constants.h'
+!
+!! model_attenuation_variables
+! type model_attenuation_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 model_attenuation_variables
+!
+! type (model_attenuation_variables) AM_V
+!! model_attenuation_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
+!
+!
+!-------------------------------------------------------------------------------------------------
+!
+! not used anymore...
+!
+! subroutine set_attenuation_regions_1D(RICB, RCMB, R670, R220, R80, AM_V)
+!
+! implicit none
+!
+! include 'constants.h'
+!
+!! model_attenuation_variables
+! type model_attenuation_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 model_attenuation_variables
+!
+! type (model_attenuation_variables) AM_V
+!! model_attenuation_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
+!
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_backazimuth.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_backazimuth.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_backazimuth.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_backazimuth.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,174 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! get backazimuth baz from event and station coordinates the, phe, ths and phs
+ subroutine get_backazimuth(the,phe,ths,phs,baz)
+
+ implicit none
+
+ double precision the, phe
+ double precision ths, phs
+ double precision az,baz,xdeg
+
+ double precision a, a1, b, b1, c, c1
+ double precision d, d1, e, e1
+ double precision ec2, eps, f, f1, g, g1, h, h1, onemec2, pherad
+ double precision phsrad, sc, sd, ss
+ double precision temp, therad, thg, thsrad
+
+ double precision, parameter :: rad = 6378.160
+ double precision, parameter :: fl = 0.00335293
+ double precision, parameter :: twopideg = 360.
+ double precision, parameter :: c00 = 1.
+ double precision, parameter :: c01 = 0.25
+ double precision, parameter :: c02 = -4.6875e-02
+ double precision, parameter :: c03 = 1.953125e-02
+ double precision, parameter :: c21 = -0.125
+ double precision, parameter :: c22 = 3.125e-02
+ double precision, parameter :: c23 = -1.46484375e-02
+ double precision, parameter :: c42 = -3.90625e-03
+ double precision, parameter :: c43 = 2.9296875e-03
+ double precision, parameter :: degtokm = 111.3199
+ double precision, parameter :: pi = 3.141592654
+ double precision, parameter :: TORAD = pi/180.
+ double precision, parameter :: TODEG = 1./TORAD
+
+
+ !=====================================================================
+ ! PURPOSE: To compute the distance and azimuth between locations.
+ !=====================================================================
+ ! INPUT ARGUMENTS:
+ ! THE: Event latitude in decimal degrees, North positive. [r]
+ ! PHE: Event longitude, East positive. [r]
+ ! THS: Array of station latitudes. [r]
+ ! PHS: Array of station longitudes. [r]
+ ! NS: Length of THS and PHS. [i]
+ !=====================================================================
+ ! OUTPUT ARGUMENTS:
+ ! DIST: Array of epicentral distances in km. [r]
+ ! AZ: Array of azimuths in degrees. [r]
+ ! BAZ: Array of back azimuths. [r]
+ ! XDEG: Array of great circle arc lengths. [r]
+ ! NERR: Error flag:
+ ! = 0 No error.
+ ! = 0904 Calculation failed internal consistency checks.
+ !=====================================================================
+ ! MODULE/LEVEL: DFM/4
+ !=====================================================================
+ ! GLOBAL INPUT:
+ ! MACH:
+ !=====================================================================
+ ! SUBROUTINES CALLED:
+ ! SACLIB: SETMSG, APCMSG
+ !=====================================================================
+ ! LOCAL VARIABLES:
+ !=====================================================================
+ ! KNOWN ERRORS:
+ ! - Problem with equation for distance. See discussion below.
+ !=====================================================================
+ ! PROCEDURE:
+ ! - Calculations are based upon the reference spheroid of 1968 and
+ ! are defined by the major radius (RAD) and the flattening (FL).
+ ! - Initialize.
+ !nerr = 0
+
+ ec2 = 2.*fl - fl*fl
+ onemec2 = 1. - ec2
+ eps = 1. + ec2/onemec2
+
+ ! - Convert event location to radians.
+ ! (Equations are unstable for latidudes of exactly 0 degrees.)
+
+ temp = the
+ if( temp == 0. ) temp = 1.0e-08
+ therad = TORAD*temp
+ pherad = TORAD*phe
+
+ ! - Must convert from geographic to geocentric coordinates in order
+ ! to use the spherical trig equations. This requires a latitude
+ ! correction given by: 1-EC2=1-2*FL+FL*FL
+
+ if ( the == 90 .or. the == -90 ) then ! special attention at the poles
+ thg = the*TORAD ! ... to avoid division by zero.
+ else
+ thg = atan( onemec2*tan( therad ) )
+ endif
+
+ d = sin( pherad )
+ e = -cos( pherad )
+ f = -cos( thg )
+ c = sin( thg )
+ a = f*e
+ b = -f*d
+ g = -c*e
+ h = c*d
+
+
+ ! -- Convert to radians.
+ temp = Ths
+ if( temp == 0. ) temp = 1.0e-08
+ thsrad = TORAD*temp
+ phsrad = TORAD*Phs
+
+ ! -- Calculate some trig constants.
+ if ( Ths == 90 .or. Ths == -90 ) then
+ thg = Ths * TORAD
+ else
+ thg = atan( onemec2*tan( thsrad ) )
+ endif
+
+ d1 = sin( phsrad )
+ e1 = -cos( phsrad )
+ f1 = -cos( thg )
+ c1 = sin( thg )
+ a1 = f1*e1
+ b1 = -f1*d1
+ g1 = -c1*e1
+ h1 = c1*d1
+ sc = a*a1 + b*b1 + c*c1
+
+ ! - Spherical trig relationships used to compute angles.
+
+ sd = 0.5*sqrt( ((a - a1)**2 + (b - b1)**2 + (c - &
+ c1)**2)*((a + a1)**2 + (b + b1)**2 + (c + c1)**2) )
+ Xdeg = atan2( sd, sc )*TODEG
+ if( Xdeg < 0. ) &
+ Xdeg = Xdeg + twopideg
+
+ ss = (a1 - d)**2 + (b1 - e)**2 + (c1)**2 - 2.
+ sc = (a1 - g)**2 + (b1 - h)**2 + (c1 - f)**2 - 2.
+ Az = atan2( ss, sc )*TODEG
+ if( Az < 0. ) &
+ Az = Az + twopideg
+
+ ss = (a - d1)**2 + (b - e1)**2 + (c)**2 - 2.
+ sc = (a - g1)**2 + (b - h1)**2 + (c - f1)**2 - 2.
+ Baz = atan2( ss, sc )*TODEG
+ if( Baz < 0. ) &
+ Baz = Baz + twopideg
+
+end subroutine get_backazimuth
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_cmt.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_cmt.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_cmt.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_cmt.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,173 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_cmt(yr,jda,ho,mi,sec,tshift_cmt,hdur,lat,long,depth,moment_tensor, &
+ DT,NSOURCES,min_tshift_cmt_original)
+
+ 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,min_tshift_cmt_original
+ double precision, dimension(NSOURCES), intent(out) :: tshift_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
+ double precision t_shift(NSOURCES)
+ character(len=5) datasource
+ character(len=256) string, CMTSOLUTION
+
+ ! initializes
+ lat(:) = 0.d0
+ long(:) = 0.d0
+ depth(:) = 0.d0
+ t_shift(:) = 0.d0
+ tshift_cmt(:) = 0.d0
+ hdur(:) = 0.d0
+ moment_tensor(:,:) = 0.d0
+ yr = 0
+ jda = 0
+ ho = 0
+ mi = 0
+ sec = 0.d0
+
+!
+!---- 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(1,"(a256)") string
+ ! skips empty lines
+ do while( len_trim(string) == 0 )
+ read(1,"(a256)") string
+ enddo
+
+ ! read header with event information
+ read(string,"(a4,i5,i3,i3,i3,i3,f6.2)") datasource,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)),*) tshift_cmt(isource)
+ read(string(12:len_trim(string)),*) t_shift(isource)
+
+ ! read half duration
+ read(1,"(a)") string
+ read(string(15:len_trim(string)),*) hdur(isource)
+
+ ! read latitude
+ read(1,"(a)") string
+ read(string(10:len_trim(string)),*) lat(isource)
+
+ ! read longitude
+ read(1,"(a)") string
+ read(string(11:len_trim(string)),*) long(isource)
+
+ ! read depth
+ read(1,"(a)") string
+ read(string(7:len_trim(string)),*) depth(isource)
+
+ ! read Mrr
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) 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)
+
+ ! checks half-duration
+ if( USE_FORCE_POINT_SOURCE ) then
+ ! half-duration is the dominant frequency of the source
+ ! point forces use a Ricker source time function
+ ! null half-duration indicates a very low-frequency source
+ ! (see constants.h: TINYVAL = 1.d-9 )
+ if( hdur(isource) < TINYVAL ) hdur(isource) = TINYVAL
+ else
+ ! null half-duration indicates a Heaviside
+ ! replace with very short error function
+ if( hdur(isource) < 5. * DT ) hdur(isource) = 5. * DT
+ endif
+
+ enddo
+
+ close(1)
+
+ ! Sets tshift_cmt to zero to initiate the simulation!
+ if(NSOURCES == 1)then
+ tshift_cmt = 0.d0
+ min_tshift_cmt_original = t_shift(1)
+ else
+ tshift_cmt(1:NSOURCES) = t_shift(1:NSOURCES)-minval(t_shift)
+ min_tshift_cmt_original = minval(t_shift)
+ endif
+
+!
+! 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
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_ellipticity.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_ellipticity.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_ellipticity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_ellipticity.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,112 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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
+
+ !> Hejun
+ ! get ellipticity according to GLL points
+ ! JAN08, 2010
+ subroutine get_ellipticity_gll(xstore,ystore,zstore,ispec,nspec,nspl,rspl,espl,espl2)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspl
+ integer::ispec,nspec
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec):: xstore,ystore,zstore
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ integer i,j,k
+
+ double precision ell
+ double precision r,theta,phi,factor
+ double precision cost,p20
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ call xyz_2_rthetaphi_dble(xstore(i,j,k,ispec),ystore(i,j,k,ispec),zstore(i,j,k,ispec),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
+
+ xstore(i,j,k,ispec)=xstore(i,j,k,ispec)*factor
+ ystore(i,j,k,ispec)=ystore(i,j,k,ispec)*factor
+ zstore(i,j,k,ispec)=zstore(i,j,k,ispec)*factor
+
+ end do
+ end do
+ end do
+ end subroutine get_ellipticity_gll
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_event_info.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_event_info.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_event_info.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_event_info.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,306 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! get information about event name and location for SAC seismograms: MPI version by Dimitri Komatitsch
+
+! Instead of using region names as event names,
+! event names given in the second row of CMT files will be used.
+! Thus, I removed old parameters ename, region, LENGTH_REGION_NAME and added event_name!!!!!!!
+! Also, t_shift is added as a new parameter to be written on sac headers!
+! by Ebru Bozdag
+
+ !subroutine get_event_info_parallel(myrank,yr,jda,ho,mi,sec,tshift_cmt, &
+ ! elat,elon,depth,mb,ename,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES)
+
+ subroutine get_event_info_parallel(myrank,yr,jda,ho,mi,sec,&
+ event_name,tshift_cmt,t_shift, &
+ elat,elon,depth,mb,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) :: yr,jda,ho,mi
+ real, intent(out) :: mb
+ double precision, intent(out) :: tshift_cmt,elat,elon,depth,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,sec
+
+ !character(len=12), intent(out) :: ename
+
+ integer, intent(in) :: NSOURCES ! must be given
+ double precision, intent(out) :: t_shift
+ character(len=20), intent(out) :: event_name
+
+
+
+!--- local variables below
+
+ integer 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,event_name,tshift_cmt,t_shift, &
+ elat,elon,depth,mb, &
+ cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES)
+
+ !call get_event_info_serial(yr,jda,ho,mi,sec,tshift_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(sec,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(tshift_cmt,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(t_shift,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ ! event location given on first, PDE line
+ 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)
+
+ ! cmt location given in CMT file
+ 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)
+ call MPI_BCAST(event_name,20,MPI_DOUBLE_PRECISION,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
+
+! This subroutine has been modified to read full CMTSOLUTION file particularly for multiple-source cases.
+! Time-shifts of all sources can be read and the minimum t_shift is taken to be written in sac headers!
+! by Ebru
+
+ subroutine get_event_info_serial(yr,jda,ho,mi,sec,event_name,tshift_cmt,t_shift,&
+ elat_pde,elon_pde,depth_pde,mb,&
+ cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES)
+
+
+ !subroutine get_event_info_serial(yr,jda,ho,mi,sec,tshift_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) :: yr,jda,ho,mi
+
+ real, intent(out) :: mb
+
+ double precision, intent(out) :: sec,tshift_cmt,t_shift
+ double precision, intent(out) :: elat_pde,elon_pde,depth_pde,cmt_lat,cmt_lon,cmt_depth,cmt_hdur
+
+ !integer, intent(in) :: LENGTH_REGION_NAME
+ !character(len=LENGTH_REGION_NAME), intent(out) :: region ! event name for SAC header
+
+ character(len=20), intent(out) :: event_name ! event name for SAC header
+
+ integer, intent(in) :: NSOURCES
+
+!--- local variables here
+
+ integer ios,mo,da,julian_day
+ integer isource
+
+ double precision, dimension(NSOURCES) :: t_s,hdur,lat,lon,depth
+ character(len=20), dimension(NSOURCES) :: e_n
+
+ real ms
+
+ character(len=5) datasource
+ character(len=150) string,CMTSOLUTION
+ !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
+ ! which is: event_id, date,origin time,latitude,longitude,depth, mb, MS, region
+
+ ! read source number isource
+ do isource=1,NSOURCES
+
+ ! read header with event information
+ read(821,*) datasource,yr,mo,da,ho,mi,sec,elat_pde,elon_pde,depth_pde,mb,ms
+ jda=julian_day(yr,mo,da)
+
+ ! ignore line with event name
+ read(821,"(a)") string
+ read(string(12:len_trim(string)),*) e_n(isource)
+
+ ! read time shift
+ read(821,"(a)") string
+ read(string(12:len_trim(string)),*) t_s(isource)
+
+ ! read half duration
+ read(821,"(a)") string
+ read(string(15:len_trim(string)),*) hdur(isource)
+
+ ! read latitude
+ read(821,"(a)") string
+ read(string(10:len_trim(string)),*) lat(isource)
+
+ ! read longitude
+ read(821,"(a)") string
+ read(string(11:len_trim(string)),*) lon(isource)
+
+ ! read depth
+ read(821,"(a)") string
+ read(string(7:len_trim(string)),*) depth(isource)
+
+ ! ignore the last 6 lines with moment tensor info
+ read(821,"(a)") string
+ read(821,"(a)") string
+ read(821,"(a)") string
+ read(821,"(a)") string
+ read(821,"(a)") string
+ read(821,"(a)") string
+ enddo
+ ! sets tshift_cmt to zero
+ tshift_cmt = 0.
+
+ ! takes first event id as event_name
+ event_name = e_n(1)
+
+ ! sets cmt infos
+ if (NSOURCES == 1) then
+ cmt_lat = lat(1)
+ cmt_lon = lon(1)
+ cmt_depth = depth(1)
+ cmt_hdur = hdur(1)
+ t_shift = t_s(1)
+ else
+ cmt_lat = -1e8
+ cmt_lon = -1e8
+ cmt_depth = -1e8
+ cmt_hdur = -1e8
+ ! takes minimum time shift of all given sources
+ t_shift = minval(t_s(1:NSOURCES))
+ endif
+
+ close(821)
+
+
+
+! ! 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)),*) tshift_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/src/get_global.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_global.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_global.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_global.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,295 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine get_global_indirect_addressing(nspec,nglob,ibool)
+
+!
+!- we can create a new indirect addressing to reduce cache misses
+! (put into this subroutine but compiler keeps on complaining that it can't vectorize loops...)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,nglob
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ ! mask to sort ibool
+ integer, dimension(:), allocatable :: mask_ibool
+ integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
+ integer :: inumber
+ integer:: i,j,k,ispec,ier
+
+ ! copies original array
+ allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(mask_ibool(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:)
+
+ ! reduces misses
+ 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
+ ! creates a new point
+ inumber = inumber + 1
+ ibool(i,j,k,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,k,ispec)) = inumber
+ else
+ ! uses an existing point created previously
+ ibool(i,j,k,ispec) = mask_ibool(copy_ibool_ori(i,j,k,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! cleanup
+ deallocate(copy_ibool_ori,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(mask_ibool,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+end subroutine get_global_indirect_addressing
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! 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/src/get_jacobian_boundaries.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_boundaries.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_jacobian_boundaries.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_jacobian_boundaries.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,528 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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,xigll,yigll,zigll)
+
+ 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)
+
+! Parameters used to calculate 2D Jacobian based upon 25 GLL points
+ integer:: i,j,k
+ double precision xelm2D(NGLLX,NGLLY),yelm2D(NGLLX,NGLLY),zelm2D(NGLLX,NGLLY)
+ double precision,dimension(NGLLX):: xigll
+ double precision,dimension(NGLLY):: yigll
+ double precision,dimension(NGLLZ):: zigll
+
+! 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
+
+ if ( .not. USE_GLL) then
+ ! 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)
+ else
+ ! get 25 GLL points for xmin
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ xelm2D(j,k) = xstore(1,j,k,ispec)
+ yelm2D(j,k) = ystore(1,j,k,ispec)
+ zelm2D(j,k) = zstore(1,j,k,ispec)
+ end do
+ end do
+ ! recalculate jacobian according to 2D GLL points
+ call recalc_jacobian_gll2D(myrank,ispecb1,xelm2D,yelm2D,zelm2D, &
+ yigll,zigll,jacobian2D_xmin,normal_xmin,&
+ NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ end if
+ endif
+
+ ! on boundary: xmax
+
+ if(iboun(2,ispec)) then
+
+ ispecb2=ispecb2+1
+ ibelm_xmax(ispecb2)=ispec
+
+ if ( .not. USE_GLL) then
+ ! 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)
+
+ else
+ ! get 25 GLL points for xmax
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ xelm2D(j,k) = xstore(NGLLX,j,k,ispec)
+ yelm2D(j,k) = ystore(NGLLX,j,k,ispec)
+ zelm2D(j,k) = zstore(NGLLX,j,k,ispec)
+ end do
+ end do
+ ! recalculate jacobian according to 2D GLL points
+ call recalc_jacobian_gll2D(myrank,ispecb2,xelm2D,yelm2D,zelm2D,&
+ yigll,zigll,jacobian2D_xmax,normal_xmax,&
+ NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ end if
+ endif
+
+ ! on boundary: ymin
+
+ if(iboun(3,ispec)) then
+
+ ispecb3=ispecb3+1
+ ibelm_ymin(ispecb3)=ispec
+
+ if ( .not. USE_GLL) then
+ ! 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)
+
+ else
+ ! get 25 GLL points for ymin
+ do k =1 ,NGLLZ
+ do i = 1,NGLLX
+ xelm2D(i,k) = xstore(i,1,k,ispec)
+ yelm2D(i,k) = ystore(i,1,k,ispec)
+ zelm2D(i,k) = zstore(i,1,k,ispec)
+ end do
+ end do
+ ! recalcualte 2D jacobian according to GLL points
+ call recalc_jacobian_gll2D(myrank,ispecb3,xelm2D,yelm2D,zelm2D,&
+ xigll,zigll,jacobian2D_ymin,normal_ymin,&
+ NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ end if
+ endif
+
+ ! on boundary: ymax
+
+ if(iboun(4,ispec)) then
+
+ ispecb4=ispecb4+1
+ ibelm_ymax(ispecb4)=ispec
+
+ if ( .not. USE_GLL) then
+ ! 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)
+
+ else
+ ! get 25 GLL points for ymax
+ do k =1,NGLLZ
+ do i = 1,NGLLX
+ xelm2D(i,k) = xstore(i,NGLLY,k,ispec)
+ yelm2D(i,k) = ystore(i,NGLLY,k,ispec)
+ zelm2D(i,k) = zstore(i,NGLLY,k,ispec)
+ end do
+ end do
+ ! recalculate jacobian for 2D GLL points
+ call recalc_jacobian_gll2D(myrank,ispecb4,xelm2D,yelm2D,zelm2D,&
+ xigll,zigll,jacobian2D_ymax,normal_ymax,&
+ NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ end if
+ endif
+
+ ! on boundary: bottom
+
+ if(iboun(5,ispec)) then
+
+ ispecb5=ispecb5+1
+ ibelm_bottom(ispecb5)=ispec
+
+ if ( .not. USE_GLL) then
+ 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)
+
+ else
+ ! get 25 GLL points for zmin
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ xelm2D(i,j) = xstore(i,j,1,ispec)
+ yelm2D(i,j) = ystore(i,j,1,ispec)
+ zelm2D(i,j) = zstore(i,j,1,ispec)
+ end do
+ end do
+ ! recalcuate 2D jacobian according to GLL points
+ call recalc_jacobian_gll2D(myrank,ispecb5,xelm2D,yelm2D,zelm2D,&
+ xigll,yigll,jacobian2D_bottom,normal_bottom,&
+ NGLLX,NGLLY,NSPEC2D_BOTTOM)
+ end if
+
+ endif
+
+ ! on boundary: top
+
+ if(iboun(6,ispec)) then
+
+ ispecb6=ispecb6+1
+ ibelm_top(ispecb6)=ispec
+
+ if ( .not. USE_GLL) then
+ 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)
+ else
+ ! get 25 GLL points for zmax
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ xelm2D(i,j) = xstore(i,j,NGLLZ,ispec)
+ yelm2D(i,j) = ystore(i,j,NGLLZ,ispec)
+ zelm2D(i,j) = zstore(i,j,NGLLZ,ispec)
+ end do
+ end do
+ ! recalcuate jacobian according to 2D gll points
+ call recalc_jacobian_gll2D(myrank,ispecb6,xelm2D,yelm2D,zelm2D,&
+ xigll,yigll,jacobian2D_top,normal_top,&
+ NGLLX,NGLLY,NSPEC2D_TOP)
+
+ end if
+
+ endif
+
+ enddo
+
+
+! check theoretical value of elements at the bottom
+ if(ispecb5 /= NSPEC2D_BOTTOM) then
+ print*,'error ispecb5:',ispecb5,NSPEC2D_BOTTOM
+ 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
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_jacobian_discontinuities.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_discontinuities.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_jacobian_discontinuities.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_jacobian_discontinuities.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,207 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine get_jacobian_discontinuities(myrank,ispec,ix_elem,iy_elem,rmin,rmax,r1,r2,r3,r4,r5,r6,r7,r8, &
+ xstore,ystore,zstore,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)
+
+ implicit none
+
+ include 'constants.h'
+
+ ! input
+ integer myrank, ispec, ix_elem, iy_elem
+ double precision rmin,rmax
+ double precision xstore(NGLLX,NGLLY,NGLLZ)
+ double precision ystore(NGLLX,NGLLY,NGLLZ)
+ double precision zstore(NGLLX,NGLLY,NGLLZ)
+ double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+ integer NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670, nex_eta_moho, ispec_superbrick
+ double precision r_moho, r_400, r_670
+ logical :: is_superbrick, USE_ONE_LAYER_SB,HONOR_1D_SPHERICAL_MOHO
+
+ ! output
+ integer ispec2D_moho_top, ispec2D_moho_bot, ispec2D_400_top, ispec2D_400_bot, ispec2D_670_top, ispec2D_670_bot
+ integer,dimension(NSPEC2D_MOHO) :: ibelm_moho_top, ibelm_moho_bot
+ integer,dimension(NSPEC2D_400) :: ibelm_400_top, ibelm_400_bot
+ integer,dimension(NSPEC2D_670) :: ibelm_670_top, ibelm_670_bot
+ real(kind=CUSTOM_REAL) :: normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO), jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO)
+ real(kind=CUSTOM_REAL) :: normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400), jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400)
+ real(kind=CUSTOM_REAL) :: normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670), jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670)
+
+ ! local variables
+ double precision, dimension(NGNOD2D) :: xelm2, yelm2, zelm2
+ double precision :: r1, r2, r3, r4, r5, r6, r7, r8
+ double precision :: target_moho_high, target_moho_low, target_400_high, target_400_low, target_670_high, target_670_low
+ integer :: nele_sub_block, ispec_list(16), map_irem_ix_12(8), map_irem_ix_34(8), map_irem_iy_odd(8), map_irem_iy_even(8)
+ integer :: map_isub_ix(4), map_isub_iy(4), map_ix(NSPEC_DOUBLING_SUPERBRICK), map_iy(NSPEC_DOUBLING_SUPERBRICK)
+ integer :: i, ispec_superbrick_current, isub_block, irem_block, irem_ix, irem_iy, ix,iy,ix_top,iy_top, ispec2D_moho_bot_map
+
+ ! ======================
+
+
+ ! find the coordinates of 9 nodes for the bottom surface element to compute the jacobian if needed
+ xelm2(1)=xstore(1,1,1)
+ yelm2(1)=ystore(1,1,1)
+ zelm2(1)=zstore(1,1,1)
+ xelm2(2)=xstore(NGLLX,1,1)
+ yelm2(2)=ystore(NGLLX,1,1)
+ zelm2(2)=zstore(NGLLX,1,1)
+ xelm2(3)=xstore(NGLLX,NGLLY,1)
+ yelm2(3)=ystore(NGLLX,NGLLY,1)
+ zelm2(3)=zstore(NGLLX,NGLLY,1)
+ xelm2(4)=xstore(1,NGLLY,1)
+ yelm2(4)=ystore(1,NGLLY,1)
+ zelm2(4)=zstore(1,NGLLY,1)
+ xelm2(5)=xstore((NGLLX+1)/2,1,1)
+ yelm2(5)=ystore((NGLLX+1)/2,1,1)
+ zelm2(5)=zstore((NGLLX+1)/2,1,1)
+ xelm2(6)=xstore(NGLLX,(NGLLY+1)/2,1)
+ yelm2(6)=ystore(NGLLX,(NGLLY+1)/2,1)
+ zelm2(6)=zstore(NGLLX,(NGLLY+1)/2,1)
+ xelm2(7)=xstore((NGLLX+1)/2,NGLLY,1)
+ yelm2(7)=ystore((NGLLX+1)/2,NGLLY,1)
+ zelm2(7)=zstore((NGLLX+1)/2,NGLLY,1)
+ xelm2(8)=xstore(1,(NGLLY+1)/2,1)
+ yelm2(8)=ystore(1,(NGLLY+1)/2,1)
+ zelm2(8)=zstore(1,(NGLLY+1)/2,1)
+ xelm2(9)=xstore((NGLLX+1)/2,(NGLLY+1)/2,1)
+ yelm2(9)=ystore((NGLLX+1)/2,(NGLLY+1)/2,1)
+ zelm2(9)=zstore((NGLLX+1)/2,(NGLLY+1)/2,1)
+
+! radii to determine if an element is on the discontinuity or not
+ target_moho_high = r_moho * (ONE + SMALLVAL)
+ target_moho_low = r_moho * (ONE - SMALLVAL)
+ target_400_high = r_400 * (ONE + SMALLVAL)
+ target_400_low = r_400 * (ONE - SMALLVAL)
+ target_670_high = r_670 * (ONE + SMALLVAL)
+ target_670_low = r_670 * (ONE - SMALLVAL)
+
+! setup the mapping array for superbrick case (only invoked for Moho bottom)
+ if (is_superbrick) then
+ map_irem_ix_12=(/2,2,0,1,0,1,0,0/)
+ map_irem_ix_34=(/1,1,0,2,0,2,0,0/)
+ map_irem_iy_odd=(/1,2,0,1,0,2,0,0/)
+ map_irem_iy_even=(/2,1,0,2,0,1,0,0/)
+ if (USE_ONE_LAYER_SB) then
+ nele_sub_block = 7
+ ispec_list=(/1,2,4,6,8,9,11,13,15,16,18,20,22,23,25,27/)
+ else
+ nele_sub_block = 8
+ ispec_list=(/1,2,4,6,9,10,12,14,17,18,20,22,25,26,28,30/)
+ endif
+ map_isub_ix=(/2,2,1,1/)
+ map_isub_iy=(/2,1,2,1/)
+
+ map_ix(1:NSPEC_DOUBLING_SUPERBRICK) = 0
+ map_iy(1:NSPEC_DOUBLING_SUPERBRICK) = 0
+
+ do i = 1, 16
+ ispec_superbrick_current=ispec_list(i)
+ isub_block = ispec_superbrick_current/nele_sub_block + 1
+ irem_block = mod(ispec_superbrick_current,nele_sub_block)
+
+ if (isub_block > 2) then
+ irem_ix = map_irem_ix_34(irem_block)
+ else
+ irem_ix = map_irem_ix_12(irem_block)
+ endif
+ if (mod(isub_block,2) == 0) then
+ irem_iy = map_irem_iy_even(irem_block)
+ else
+ irem_iy = map_irem_iy_odd(irem_block)
+ endif
+ map_ix(ispec_list(i)) = (map_isub_ix(isub_block) - 1) * 2 + irem_ix
+ map_iy(ispec_list(i)) = (map_isub_iy(isub_block) - 1) * 2 + irem_iy
+! if (ispec_superbrick == 1 .and. myrank == 0) &
+! write(*,'(10i4)') i, ispec_list(i), map_ix(ispec_list(i)), map_iy(ispec_list(i))
+ enddo
+ endif
+
+! determine if the elements are on the discontinuity, and calculate the boundary jaocobian if needed
+ if (.not. is_superbrick) then
+
+! Moho top
+ if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO .and. &
+ abs(rmin-r_moho)/r_moho < SMALLVAL .and. r1 < target_moho_high .and. r2 < target_moho_high &
+ .and. r3 < target_moho_high .and. r4 < target_moho_high) then
+ ispec2D_moho_top = ispec2D_moho_top + 1
+ ibelm_moho_top(ispec2D_moho_top) = ispec
+ call compute_jacobian_2D(myrank,ispec2D_moho_top,xelm2,yelm2,zelm2,dershape2D_bottom, &
+ jacobian2D_moho,normal_moho,NGLLX,NGLLY,NSPEC2D_MOHO)
+! 400 top
+ else if (abs(rmin-r_400)/r_400 < SMALLVAL .and. r1 < target_400_high .and. r2 < target_400_high &
+ .and. r3 < target_400_high .and. r4 < target_400_high) then
+ ispec2D_400_top = ispec2D_400_top + 1
+ ibelm_400_top(ispec2D_400_top) = ispec
+ call compute_jacobian_2D(myrank,ispec2D_400_top,xelm2,yelm2,zelm2,dershape2D_bottom, &
+ jacobian2D_400,normal_400,NGLLX,NGLLY,NSPEC2D_400)
+
+! 400 bot
+ else if (abs(rmax-r_400)/r_400 < SMALLVAL .and. r5 > target_400_low .and. r6 > target_400_low &
+ .and. r7 > target_400_low .and. r8 > target_400_low) then
+ ispec2D_400_bot = ispec2D_400_bot + 1
+ ibelm_400_bot(ispec2D_400_bot) = ispec
+
+! 670 top
+ else if (abs(rmin-r_670)/r_670 < SMALLVAL .and. r1 < target_670_high .and. r2 < target_670_high &
+ .and. r3 < target_670_high .and. r4 < target_670_high) then
+ ispec2D_670_top = ispec2D_670_top + 1
+ ibelm_670_top(ispec2D_670_top) = ispec
+ call compute_jacobian_2D(myrank,ispec2D_670_top,xelm2,yelm2,zelm2,dershape2D_bottom, &
+ jacobian2D_670,normal_670,NGLLX,NGLLY,NSPEC2D_670)
+! 670 bot
+ else if (abs(rmax-r_670)/r_670 < SMALLVAL .and. r5 > target_670_low .and. r6 > target_670_low &
+ .and. r7 > target_670_low .and. r8 > target_670_low) then
+ ispec2D_670_bot = ispec2D_670_bot + 1
+ ibelm_670_bot(ispec2D_670_bot) = ispec
+ endif
+
+ else ! superbrick case
+ ! Moho bot (special care should be taken to deal with mapping 2D element indices)
+ if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO .and. &
+ abs(rmax-r_moho)/r_moho < SMALLVAL .and. r5 > target_moho_low .and. r6 > target_moho_low &
+ .and. r7 > target_moho_low .and. r8 > target_moho_low) then
+ ispec2D_moho_bot = ispec2D_moho_bot + 1
+ ix=map_ix(ispec_superbrick)
+ iy=map_iy(ispec_superbrick)
+ if (ix == 0 .or. iy == 0) call exit_mpi(myrank, 'Check (ix,iy) on the Moho bot is 0')
+ ix_top = (ix_elem - 1) + ix
+ iy_top = (iy_elem - 1) + iy
+ ispec2D_moho_bot_map = (ix_top - 1) * nex_eta_moho + iy_top
+! if (myrank == 0) write(*,'(10i6)') ix_elem, iy_elem, ispec_superbrick, ix, iy, ix_top, iy_top, ispec2D_moho_bot_map
+ ibelm_moho_bot(ispec2D_moho_bot_map) = ispec
+ endif
+ endif
+
+
+end subroutine get_jacobian_discontinuities
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_model.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_model.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_model.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,436 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_model(myrank,iregion_code,ispec,nspec,idoubling, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ rhostore,dvpstore,nspec_ani, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_stacey,rho_vp,rho_vs, &
+ xstore,ystore,zstore, &
+ rmin,rmax,RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220, &
+ R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ tau_s,tau_e_store,Qmu_store,T_c_source,vx,vy,vz,vnspec, &
+ ABSORBING_CONDITIONS,elem_in_crust,elem_in_mantle)
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer myrank,iregion_code,ispec,nspec,idoubling
+
+ 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)
+ real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) dvpstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer nspec_ani
+ 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
+
+ integer nspec_stacey
+ real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey),rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
+
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
+ double precision rmin,rmax,RCMB,RICB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+ ! attenuation values
+ integer vx,vy,vz,vnspec
+ double precision, dimension(N_SLS) :: tau_s
+ 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 ABSORBING_CONDITIONS
+ logical elem_in_crust,elem_in_mantle
+
+ ! local parameters
+ double precision xmesh,ymesh,zmesh
+ ! 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
+ double precision, dimension(N_SLS) :: tau_e
+
+ ! local parameters
+ double precision rho,dvp
+ double precision vpv,vph,vsv,vsh,eta_aniso
+ double precision Qkappa,Qmu
+ double precision r,r_prem,moho
+ integer i,j,k
+
+ ! loops over all gll points for this spectral element
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! initializes values
+ rho = 0.d0
+ vpv = 0.d0
+ vph = 0.d0
+ vsv = 0.d0
+ vsh = 0.d0
+ eta_aniso = 0.d0
+ c11 = 0.d0
+ c12 = 0.d0
+ c13 = 0.d0
+ c14 = 0.d0
+ c15 = 0.d0
+ c16 = 0.d0
+ c22 = 0.d0
+ c23 = 0.d0
+ c24 = 0.d0
+ c25 = 0.d0
+ c26 = 0.d0
+ c33 = 0.d0
+ c34 = 0.d0
+ c35 = 0.d0
+ c36 = 0.d0
+ c44 = 0.d0
+ c45 = 0.d0
+ c46 = 0.d0
+ c55 = 0.d0
+ c56 = 0.d0
+ c66 = 0.d0
+ Qmu = 0.d0
+ Qkappa = 0.d0 ! not used, not stored so far...
+ tau_e(:) = 0.d0
+ dvp = 0.d0
+
+ ! sets xyz coordinates of GLL point
+ xmesh = xstore(i,j,k,ispec)
+ ymesh = ystore(i,j,k,ispec)
+ zmesh = zstore(i,j,k,ispec)
+
+ ! exact point location radius
+ r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*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
+ ! checks r_prem,rmin/rmax and assigned idoubling
+ call get_model_check_idoubling(r_prem,xmesh,ymesh,zmesh,rmin,rmax,idoubling, &
+ RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R220,R670,myrank)
+
+ ! gets reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
+ call meshfem3D_models_get1D_val(myrank,iregion_code,idoubling, &
+ r_prem,rho,vpv,vph,vsv,vsh,eta_aniso, &
+ Qkappa,Qmu,RICB,RCMB, &
+ RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
+ RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ ! gets the 3-D model parameters for the mantle
+ call meshfem3D_models_get3Dmntl_val(iregion_code,r_prem,rho,dvp,&
+ vpv,vph,vsv,vsh,eta_aniso, &
+ RCMB,R670,RMOHO, &
+ xmesh,ymesh,zmesh,r, &
+ c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
+
+ ! gets the 3-D crustal model
+ if( CRUSTAL ) then
+ if( .not. elem_in_mantle) &
+ call meshfem3D_models_get3Dcrust_val(iregion_code,xmesh,ymesh,zmesh,r, &
+ vpv,vph,vsv,vsh,rho,eta_aniso,dvp, &
+ c11,c12,c13,c14,c15,c16,c22,c23,c24,c25, &
+ c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66, &
+ elem_in_crust,moho)
+ endif
+
+ ! overwrites with tomographic model values (from iteration step) here, given at all GLL points
+ call meshfem3D_models_impose_val(vpv,vph,vsv,vsh,rho,dvp,eta_aniso,&
+ myrank,iregion_code,ispec,i,j,k)
+
+ ! checks vpv: if close to zero then there is probably an error
+ if( vpv < TINYVAL ) then
+ print*,'error vpv: ',vpv,vph,vsv,vsh,rho
+ print*,'radius:',r*R_EARTH_KM
+ call exit_mpi(myrank,'error get_model values')
+ endif
+
+ !> Hejun
+ ! New Attenuation assignment
+ ! Define 3D and 1D Attenuation after moho stretch
+ ! and before TOPOGRAPHY/ELLIPCITY
+ !
+ !note: only Qmu attenuation considered, Qkappa attenuation not used so far...
+ if( ATTENUATION ) &
+ call meshfem3D_models_getatten_val(idoubling,xmesh,ymesh,zmesh,r_prem, &
+ tau_e,tau_s,T_c_source, &
+ moho,Qmu,Qkappa,elem_in_crust) ! R80
+
+! define elastic parameters in the model
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+ rhostore(i,j,k,ispec) = sngl(rho)
+ kappavstore(i,j,k,ispec) = sngl(rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0))
+ kappahstore(i,j,k,ispec) = sngl(rho*(vph*vph - 4.d0*vsh*vsh/3.d0))
+ muvstore(i,j,k,ispec) = sngl(rho*vsv*vsv)
+ muhstore(i,j,k,ispec) = sngl(rho*vsh*vsh)
+ eta_anisostore(i,j,k,ispec) = sngl(eta_aniso)
+
+ if (HETEROGEN_3D_MANTLE) then
+ dvpstore(i,j,k,ispec) = sngl(dvp)
+ 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
+ !double precision
+
+ rhostore(i,j,k,ispec) = rho
+ kappavstore(i,j,k,ispec) = rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0)
+ kappahstore(i,j,k,ispec) = rho*(vph*vph - 4.d0*vsh*vsh/3.d0)
+ muvstore(i,j,k,ispec) = rho*vsv*vsv
+ muhstore(i,j,k,ispec) = rho*vsh*vsh
+ eta_anisostore(i,j,k,ispec) = eta_aniso
+
+ if (HETEROGEN_3D_MANTLE) then
+ dvpstore(i,j,k,ispec) = dvp
+ 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 !CUSTOM_REAL
+
+ !> Hejun
+ ! No matter 1D or 3D attenuation, we save all gll point values
+ if(ATTENUATION) 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
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine get_model_check_idoubling(r_prem,x,y,z,rmin,rmax,idoubling, &
+ RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R220,R670,myrank)
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ !include "constants.h"
+
+ integer idoubling,myrank
+
+ double precision r_prem,rmin,rmax,x,y,z
+
+ double precision RICB,RCMB,RTOPDDOUBLEPRIME,R670,R220
+ double precision r_m,r,theta,phi
+
+ ! compute real physical radius in meters
+ r_m = r_prem * R_EARTH
+
+ ! checks layers
+ if( abs(rmax - rmin ) < TINYVAL ) then
+ ! there's probably an error
+ print*,'error layer radius min/max:',rmin,rmax
+ print*,' point radius: ',r_prem
+ call exit_mpi(myrank,'error in get_model_check_idoubling() layer radius')
+ endif
+
+
+ ! 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_m >= 0.d0 .and. r_m < 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) then
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+ print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
+ print*,' idoubling/IFLAG: ',idoubling,IFLAG_INNER_CORE_NORMAL,'-to-',IFLAG_IN_FICTITIOUS_CUBE
+ call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for inner core point')
+ endif
+ !
+ !--- outer core
+ !
+ else if(r_m > RICB .and. r_m < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) then
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+ print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
+ print*,' idoubling/IFLAG: ',idoubling,IFLAG_OUTER_CORE_NORMAL
+ call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for outer core point')
+ endif
+ !
+ !--- D" at the base of the mantle
+ !
+ else if(r_m > RCMB .and. r_m < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) then
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+ print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
+ print*,' dprime radius/RCMB/RTOPDDOUBLEPRIME:',r_m, RCMB,RTOPDDOUBLEPRIME
+ print*,' idoubling/IFLAG: ',idoubling,IFLAG_MANTLE_NORMAL
+ call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for D" point')
+ endif
+ !
+ !--- mantle: from top of D" to d670
+ !
+ else if(r_m > RTOPDDOUBLEPRIME .and. r_m < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) then
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+ print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
+ print*,' idoubling/IFLAG: ',idoubling,IFLAG_MANTLE_NORMAL
+ call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for top D" -> d670 point')
+ endif
+
+ !
+ !--- mantle: from d670 to d220
+ !
+ else if(r_m > R670 .and. r_m < R220) then
+ if(idoubling /= IFLAG_670_220) then
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+ print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
+ print*,' idoubling/IFLAG: ',idoubling,IFLAG_670_220
+ call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for d670 -> d220 point')
+ endif
+
+ !
+ !--- mantle and crust: from d220 to MOHO and then to surface
+ !
+ else if(r_m > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) then
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+ print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
+ print*,' idoubling/IFLAG: ',idoubling,IFLAG_220_80,IFLAG_80_MOHO,IFLAG_CRUST
+ call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for d220 -> Moho -> surface point')
+ endif
+
+ endif
+
+ end subroutine get_model_check_idoubling
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_model_parameters.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_model_parameters.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_model_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_model_parameters.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,668 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_model_parameters(MODEL,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
+ CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO, &
+ ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY, &
+ OCEANS,TOPOGRAPHY, &
+ ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R120,R220,R400,R600,R670,R771, &
+ RTOPDDOUBLEPRIME,RCMB,RICB,RMOHO_FICTITIOUS_IN_MESHER, &
+ R80_FICTITIOUS_IN_MESHER,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS)
+
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=150) MODEL
+
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ logical ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
+ CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO,&
+ ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY
+
+ logical OCEANS,TOPOGRAPHY
+
+ double precision ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
+
+ double precision RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS
+
+ ! turns on/off corresponding 1-D/3-D model flags
+ call get_model_parameters_flags(MODEL,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
+ CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO, &
+ ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY, &
+ OCEANS,TOPOGRAPHY)
+
+ ! sets radius for each discontinuity and ocean density values
+ call get_model_parameters_radii(REFERENCE_1D_MODEL,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771, &
+ RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RMOHO_FICTITIOUS_IN_MESHER, &
+ R80_FICTITIOUS_IN_MESHER, &
+ RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
+ HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL)
+
+
+ end subroutine get_model_parameters
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine get_model_parameters_flags(MODEL,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
+ CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO, &
+ ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY, &
+ OCEANS,TOPOGRAPHY)
+
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=150) MODEL
+
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ logical ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
+ CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO,&
+ ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY
+ logical OCEANS,TOPOGRAPHY
+
+ ! local parameters
+ character(len=4) ending
+ character(len=8) ending_1Dcrust
+
+ character(len=150) MODEL_ROOT
+ logical :: impose_1Dcrust
+
+ ! defaults:
+ !
+ ! 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.
+ !
+
+ ! extract ending of model name
+ ending = ' '
+ if( len_trim(MODEL) > 4 ) ending = MODEL(len_trim(MODEL)-3:len_trim(MODEL))
+
+ ! determines if the anisotropic inner core option should be turned on
+ if( ending == '_AIC' ) then
+ ANISOTROPIC_INNER_CORE = .true.
+ ! in case it has an ending for the inner core, remove it from the name
+ MODEL_ROOT = MODEL(1: len_trim(MODEL)-4)
+ else
+ ANISOTROPIC_INNER_CORE = .false.
+ ! sets root name of model to original one
+ MODEL_ROOT = MODEL
+ endif
+
+ ! checks with '_1Dcrust' option
+ impose_1Dcrust = .false.
+ ending_1Dcrust = ' '
+ if( len_trim(MODEL_ROOT) > 8 ) &
+ ending_1Dcrust = MODEL_ROOT(len_trim(MODEL_ROOT)-7:len_trim(MODEL_ROOT))
+ if( ending_1Dcrust == '_1Dcrust' ) then
+ impose_1Dcrust = .true.
+ ! in case it has an ending for the inner core, remove it from the name
+ MODEL_ROOT = MODEL_ROOT(1: len_trim(MODEL)-8)
+ endif
+
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+
+ ! uses PREM as the 1D reference model by default
+ ! uses no mantle heterogeneities by default
+ ! uses no 3D model by default
+ ANISOTROPIC_3D_MANTLE = .false.
+ ATTENUATION_3D = .false.
+ CASE_3D = .false.
+ CRUSTAL = .false.
+ HETEROGEN_3D_MANTLE = .false.
+ HONOR_1D_SPHERICAL_MOHO = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ONE_CRUST = .false.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+ THREE_D_MODEL = 0
+ TRANSVERSE_ISOTROPY = .false.
+
+ ! model specifics
+
+ ! 1-D models
+ if(MODEL_ROOT == '1D_isotropic_prem') then
+ HONOR_1D_SPHERICAL_MOHO = .true.
+
+ else if(MODEL_ROOT == '1D_transversely_isotropic_prem') then
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == '1D_iasp91' .or. MODEL_ROOT == '1D_1066a' .or. &
+ MODEL_ROOT == '1D_ak135' .or. MODEL_ROOT == '1D_jp3d' .or. &
+ MODEL_ROOT == '1D_sea99') then
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ if(MODEL_ROOT == '1D_iasp91') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
+ else if(MODEL_ROOT == '1D_1066a') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
+ else if(MODEL_ROOT == '1D_ak135') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
+ else if(MODEL_ROOT == '1D_jp3d') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
+ else if(MODEL_ROOT == '1D_sea99') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ else
+ stop 'reference 1D Earth model unknown'
+ endif
+
+ else if(MODEL_ROOT == '1D_ref') then
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == '1D_ref_iso') then
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
+
+ else if(MODEL_ROOT == '1D_isotropic_prem_onecrust') then
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL_ROOT == '1D_transversely_isotropic_prem_onecrust') then
+ TRANSVERSE_ISOTROPY = .true.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL_ROOT == '1D_iasp91_onecrust' .or. MODEL_ROOT == '1D_1066a_onecrust' &
+ .or. MODEL_ROOT == '1D_ak135_onecrust') then
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+ if(MODEL_ROOT == '1D_iasp91_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
+ else if(MODEL_ROOT == '1D_1066a_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
+ else if(MODEL_ROOT == '1D_ak135_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
+ else
+ stop 'reference 1D Earth model unknown'
+ endif
+
+ ! 3-D models
+ else if(MODEL_ROOT == 'transversely_isotropic_prem_plus_3D_crust_2.0') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ONE_CRUST = .true.
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == 's20rts') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ THREE_D_MODEL = THREE_D_MODEL_S20RTS
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == 's40rts') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ THREE_D_MODEL = THREE_D_MODEL_S40RTS
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == 'sea99_jp3d1994') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ THREE_D_MODEL = THREE_D_MODEL_SEA99_JP3D
+
+ else if(MODEL_ROOT == 'sea99') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ THREE_D_MODEL = THREE_D_MODEL_SEA99
+
+ else if(MODEL_ROOT == 'jp3d1994') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
+ THREE_D_MODEL = THREE_D_MODEL_JP3D
+
+ else if(MODEL_ROOT == 's362ani') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == 's362iso') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+
+ else if(MODEL_ROOT == 's362wmani') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
+ THREE_D_MODEL = THREE_D_MODEL_S362WMANI
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == 's362ani_prem') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI_PREM
+
+ else if(MODEL_ROOT == 's362ani_3DQ') then
+ ATTENUATION_3D = .true.
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == 's362iso_3DQ') then
+ ATTENUATION_3D = .true.
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+
+ else if(MODEL_ROOT == 's29ea') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
+ THREE_D_MODEL = THREE_D_MODEL_S29EA
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == '3D_attenuation') then
+ ATTENUATION_3D = .true.
+ CASE_3D = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL_ROOT == '3D_anisotropic') then
+ ANISOTROPIC_3D_MANTLE = .true.
+ CASE_3D = .true.
+ ONE_CRUST = .true.
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == 'heterogen') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ HETEROGEN_3D_MANTLE = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+ TRANSVERSE_ISOTROPY = .true.
+
+ else if(MODEL_ROOT == 'PPM') then
+ ! overimposed based on isotropic-prem
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ THREE_D_MODEL = THREE_D_MODEL_PPM
+ TRANSVERSE_ISOTROPY = .true. ! to use transverse-isotropic prem
+
+ else if(MODEL_ROOT == 'GLL') then
+ ! model will be given on local basis, at all GLL points,
+ ! as from meshfem3d output from routine save_arrays_solver()
+ ! based on model s29ea
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
+ THREE_D_MODEL = THREE_D_MODEL_GLL
+ TRANSVERSE_ISOTROPY = .true.
+ ! note: after call to this routines read_compute_parameters() we will set
+ ! mgll_v%model_gll flag and reset
+ ! THREE_D_MODEL = THREE_D_MODEL_S29EA
+ ! (not done here because we will use mgll_v%model_gll flag to identify this
+ ! model, based upon the s29ea model, but putting mgll_v as parameter to this
+ ! routine involves too many changes. )
+
+ else if(MODEL == 'gapp2') then
+ CASE_3D = .true.
+ CRUSTAL = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ONE_CRUST = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+ THREE_D_MODEL = THREE_D_MODEL_GAPP2
+ TRANSVERSE_ISOTROPY = .true.
+
+ else
+ print*
+ print*,'error model: ',trim(MODEL)
+ stop 'model not implemented yet, edit get_model_parameters.f90 and recompile'
+ endif
+
+ ! suppress the crustal layers
+ if( SUPPRESS_CRUSTAL_MESH ) then
+ CRUSTAL = .false.
+ OCEANS = .false.
+ ONE_CRUST = .false.
+ TOPOGRAPHY = .false.
+ endif
+
+ ! additional option for 3D mantle models:
+ ! this takes crust from reference 1D model rather than a 3D crust;
+ if( impose_1Dcrust ) then
+ ! no 3D crust
+ CRUSTAL = .false.
+ ! no crustal moho stretching
+ CASE_3D = .false.
+ ! mesh honors the 1D moho depth
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ! 2 element layers in top crust region rather than just one
+ ONE_CRUST = .false.
+ endif
+
+ ! checks flag consistency for crust
+ if( HONOR_1D_SPHERICAL_MOHO .and. CRUSTAL ) &
+ stop 'honor 1D spherical moho excludes having 3D crustal structure'
+
+ ! checks 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'
+
+
+ end subroutine get_model_parameters_flags
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine get_model_parameters_radii(REFERENCE_1D_MODEL,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771, &
+ RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RMOHO_FICTITIOUS_IN_MESHER, &
+ R80_FICTITIOUS_IN_MESHER, &
+ RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
+ HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL)
+
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer REFERENCE_1D_MODEL
+
+ double precision ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
+
+ double precision RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS
+
+ logical HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL
+
+! 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)
+
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ ! default: PREM
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R120 = -1.d0 ! by default there is no d120 discontinuity, except in IASP91, therefore set to fictitious value
+ R220 = 6151000.d0
+ R400 = 5971000.d0
+ R600 = 5771000.d0
+ R670 = 5701000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3480000.d0
+ RICB = 1221000.d0
+
+ ! density ocean
+ RHO_OCEANS = 1020.0 / RHOAV ! value common to all models
+ ! densities fluid outer core
+ RHO_TOP_OC = 9903.4384 / RHOAV
+ RHO_BOTTOM_OC = 12166.5885 / RHOAV
+
+ ! differing 1-D model radii
+ 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_1DREF) 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
+
+ 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
+ ! 1D models: all honor their spherical moho
+ RMOHO_FICTITIOUS_IN_MESHER = RMOHO
+ R80_FICTITIOUS_IN_MESHER = R80
+ else
+ ! 3D models do not honor PREM moho but a fictitious moho at 40km depth:
+ ! either to make simulation cheaper or to have a 3D crustal structure
+ RMOHO_FICTITIOUS_IN_MESHER = (R80 + R_EARTH) / 2.0d0
+ R80_FICTITIOUS_IN_MESHER = R80
+ if( CRUSTAL .and. CASE_3D ) then
+ !> Hejun
+ ! mesh will honor 3D crustal moho topography
+ ! moves MOHO up 5km to honor moho topography deeper than 35 km
+ ! moves R80 down to 120km depth in order to have less squeezing for elements below moho
+ RMOHO_FICTITIOUS_IN_MESHER = RMOHO_FICTITIOUS_IN_MESHER + RMOHO_STRETCH_ADJUSTEMENT
+ R80_FICTITIOUS_IN_MESHER = R80_FICTITIOUS_IN_MESHER + R80_STRETCH_ADJUSTEMENT
+ endif
+ endif
+
+ end subroutine get_model_parameters_radii
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_shape2D.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_shape2D.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_shape2D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_shape2D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/get_shape3D.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_shape3D.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_shape3D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_shape3D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/get_value_parameters.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/get_value_parameters.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_value_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/get_value_parameters.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,101 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine 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
+
+!--------------------
+
+! 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
+
+!--------------------
+
+!
+! unused routines:
+!
+
+! 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
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/gll_library.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/gll_library.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/gll_library.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/gll_library.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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/src/hex_nodes.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/hex_nodes.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/hex_nodes.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/hex_nodes.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/initialize_simulation.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/initialize_simulation.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/initialize_simulation.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/initialize_simulation.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,522 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine initialize_simulation(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,NEX_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,SIMULATION_TYPE, &
+ DT,ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670,R771,&
+ RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ HDUR_MOVIE,MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST, &
+ MOVIE_NORTH,MOVIE_SOUTH,MOVIE_SURFACE,MOVIE_VOLUME, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
+ OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
+ LOCAL_PATH,OUTPUT_FILES, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top, &
+ this_region_has_a_doubling,rmins,rmaxs, &
+ TOPOGRAPHY,HONOR_1D_SPHERICAL_MOHO,ONE_CRUST, &
+ nspl,rspl,espl,espl2,ibathy_topo, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ xigll,yigll,zigll,wxgll,wygll,wzgll,wgll_cube, &
+ hprime_xx,hprime_yy,hprime_zz,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ rec_filename,STATIONS,nrec,NOISE_TOMOGRAPHY)
+
+ implicit none
+
+ include 'mpif.h'
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ ! 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, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
+
+ logical MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT,&
+ OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) LOCAL_PATH,OUTPUT_FILES
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ratio_sampling_array,ner
+ 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
+
+
+ ! mesh model parameters
+ logical TOPOGRAPHY,HONOR_1D_SPHERICAL_MOHO,ONE_CRUST
+ !logical COMPUTE_AND_STORE_STRAIN
+
+ ! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ ! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+
+ ! 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,NGLLX) :: hprime_xxT,hprimewgll_xxT
+ 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
+
+ character(len=150) rec_filename,STATIONS
+ integer nrec
+
+ ! local parameters
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC_computed,NGLOB_computed, &
+ NSPEC2D_XI,NSPEC2D_ETA,NSPEC1D_RADIAL
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ integer :: ratio_divide_central_cube
+ integer :: sizeprocs
+ integer :: ier,i,j,ios
+ integer :: NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,NPROC_XI,NPROC_ETA
+ double precision :: RMOHO_FICTITIOUS_IN_MESHER,R120,R_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,&
+ CENTER_LATITUDE_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,ANGULAR_WIDTH_XI_IN_DEGREES,&
+ GAMMA_ROTATION_AZIMUTH
+ integer :: REFERENCE_1D_MODEL,THREE_D_MODEL
+ logical :: TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS, &
+ ATTENUATION,ATTENUATION_3D,ROTATION,ELLIPTICITY,GRAVITY,CASE_3D,ISOTROPIC_3D_MANTLE, &
+ HETEROGEN_3D_MANTLE,CRUSTAL,INFLATE_CENTRAL_CUBE
+ character(len=150) :: MODEL,dummystring
+ integer, external :: err_occurred
+
+ ! 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
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+ 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,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC_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.,NOISE_TOMOGRAPHY)
+
+ if(err_occurred() /= 0) then
+ call exit_MPI(myrank,'an error occurred while reading the parameter file')
+ endif
+
+ endif
+
+ ! distributes parameters from master to all processes
+ ! note: uses NSPEC_computed,NGLOB_computed as arguments
+ call broadcast_compute_parameters(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ RMOHO_FICTITIOUS_IN_MESHER, &
+ MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
+ OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
+ LOCAL_PATH,MODEL, &
+ 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, &
+ ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
+ HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
+ ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY)
+
+ ! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ ! open main output file, only written to by process 0
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
+ open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_solver.txt',status='unknown',action='write')
+
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ write(IMAIN,*) '******************************'
+ write(IMAIN,*) '**** Specfem3D MPI Solver ****'
+ write(IMAIN,*) '******************************'
+ write(IMAIN,*)
+ write(IMAIN,*)
+
+ if(FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field'
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
+ write(IMAIN,*)
+
+ write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
+ write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
+ write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
+ write(IMAIN,*) 'There are ',NCHUNKS,' chunks'
+ write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in all the chunks'
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'NDIM = ',NDIM
+ write(IMAIN,*)
+ write(IMAIN,*) 'NGLLX = ',NGLLX
+ write(IMAIN,*) 'NGLLY = ',NGLLY
+ write(IMAIN,*) 'NGLLZ = ',NGLLZ
+ write(IMAIN,*)
+
+ ! write information about precision used for floating-point operations
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IMAIN,*) 'using single precision for the calculations'
+ else
+ write(IMAIN,*) 'using double precision for the calculations'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ', &
+ tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
+ write(IMAIN,*)
+
+ write(IMAIN,*) 'model:'
+
+ if(ISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) ' incorporates 3-D lateral variations'
+ else
+ write(IMAIN,*) ' no 3-D lateral variations'
+ endif
+ if(HETEROGEN_3D_MANTLE) then
+ write(IMAIN,*) ' incorporates heterogeneities in the mantle'
+ else
+ write(IMAIN,*) ' no heterogeneities in the mantle'
+ endif
+ if(CRUSTAL) then
+ write(IMAIN,*) ' incorporates crustal variations'
+ else
+ write(IMAIN,*) ' no crustal variations'
+ endif
+ if(ONE_CRUST) then
+ write(IMAIN,*) ' uses one layer only in PREM crust'
+ else
+ write(IMAIN,*) ' uses unmodified 1D crustal model with two layers'
+ endif
+ if(TRANSVERSE_ISOTROPY) then
+ write(IMAIN,*) ' incorporates transverse isotropy'
+ else
+ write(IMAIN,*) ' no transverse isotropy'
+ endif
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+ write(IMAIN,*) ' incorporates anisotropic inner core'
+ else
+ write(IMAIN,*) ' no inner-core anisotropy'
+ endif
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+ write(IMAIN,*) ' incorporates anisotropic mantle'
+ else
+ write(IMAIN,*) ' no general mantle anisotropy'
+ endif
+
+ write(IMAIN,*)
+ 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(initialization specfem)')
+
+ ! check that the code has been compiled with the right values
+ if (NSPEC_computed(IREGION_CRUST_MANTLE) /= NSPEC_CRUST_MANTLE) then
+ write(IMAIN,*) 'NSPEC_CRUST_MANTLE:',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_OUTER_CORE:',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_INNER_CORE:',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,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,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,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,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,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,ELLIPTICITY_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 10')
+ endif
+ if (OCEANS .NEQV. OCEANS_VAL) then
+ write(IMAIN,*) 'OCEANS:',OCEANS,OCEANS_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 10')
+ endif
+ if (NPROCTOT /= NPROCTOT_VAL) then
+ write(IMAIN,*) 'NPROCTOT:',NPROCTOT,NPROCTOT_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 11')
+ endif
+ if (NPROC_XI /= NPROC_XI_VAL) then
+ write(IMAIN,*) 'NPROC_XI:',NPROC_XI,NPROC_XI_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 11')
+ endif
+ if (NPROC_ETA /= NPROC_ETA_VAL) then
+ write(IMAIN,*) 'NPROC_ETA:',NPROC_ETA,NPROC_ETA_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,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,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,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,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,ANISOTROPIC_INNER_CORE_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 16')
+ endif
+
+ ! check simulation pararmeters
+ if (SIMULATION_TYPE /= 1 .and. SIMULATION_TYPE /= 2 .and. SIMULATION_TYPE /= 3) &
+ call exit_MPI(myrank, 'SIMULATION_TYPE can only be 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((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then
+ if ( ATTENUATION_VAL) then
+ ! checks mimic flag:
+ ! attenuation for adjoint simulations must have USE_ATTENUATION_MIMIC set by xcreate_header_file
+ if( USE_ATTENUATION_MIMIC .eqv. .false. ) &
+ call exit_MPI(myrank,'error in compiled attenuation parameters, please recompile solver 17b')
+
+ ! user output
+ if( myrank == 0 ) write(IMAIN,*) 'incorporates ATTENUATION for time-reversed simulation'
+ endif
+
+ ! checks adjoint array dimensions
+ if(NSPEC_CRUST_MANTLE_ADJOINT /= NSPEC_CRUST_MANTLE &
+ .or. NSPEC_OUTER_CORE_ADJOINT /= NSPEC_OUTER_CORE &
+ .or. NSPEC_INNER_CORE_ADJOINT /= NSPEC_INNER_CORE &
+ .or. NGLOB_CRUST_MANTLE_ADJOINT /= NGLOB_CRUST_MANTLE &
+ .or. NGLOB_OUTER_CORE_ADJOINT /= NGLOB_OUTER_CORE &
+ .or. NGLOB_INNER_CORE_ADJOINT /= NGLOB_INNER_CORE) &
+ call exit_MPI(myrank, 'improper dimensions of adjoint arrays, please recompile solver 18')
+ endif
+
+ ! checks 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')
+ endif
+
+ ! checks strain storage
+ if (ATTENUATION_VAL .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD &
+ .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
+ if( COMPUTE_AND_STORE_STRAIN .neqv. .true. ) &
+ call exit_MPI(myrank, 'error in compiled compute_and_store_strain parameter, please recompile solver 19')
+ else
+ if( COMPUTE_AND_STORE_STRAIN .neqv. .false. ) &
+ call exit_MPI(myrank, 'error in compiled compute_and_store_strain parameter, please recompile solver 20')
+ endif
+
+ if (SIMULATION_TYPE == 3 .and. (ANISOTROPIC_3D_MANTLE_VAL .or. ANISOTROPIC_INNER_CORE_VAL)) &
+ call exit_MPI(myrank, 'anisotropic model is not implemented for kernel simulations yet')
+
+ ! checks model for transverse isotropic kernel computation
+ if( SAVE_TRANSVERSE_KL ) then
+ if( ANISOTROPIC_3D_MANTLE_VAL ) then
+ call exit_mpi(myrank,'error SAVE_TRANSVERSE_KL: Earth model not supported yet')
+ endif
+ if( SIMULATION_TYPE == 3 ) then
+ if( .not. ANISOTROPIC_KL ) then
+ call exit_mpi(myrank,'error SAVE_TRANSVERSE_KL: needs anisotropic kernel calculations')
+ endif
+ endif
+ endif
+
+ ! make ellipticity
+ if(ELLIPTICITY_VAL) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
+
+ ! read topography and bathymetry file
+ if(myrank == 0 .and. (TOPOGRAPHY .or. OCEANS_VAL)) 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)
+
+ ! 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)
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+
+ ! check that optimized routines from Deville et al. (2002) can be used
+ if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
+ stop 'Deville et al. (2002) routines can only be used if NGLLX = NGLLY = NGLLZ = 5'
+
+ ! define transpose of derivation matrix
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ hprime_xxT(j,i) = hprime_xx(i,j)
+ hprimewgll_xxT(j,i) = hprimewgll_xx(i,j)
+ enddo
+ enddo
+ endif
+
+ ! counts receiver stations
+ if (SIMULATION_TYPE == 1) then
+ rec_filename = 'DATA/STATIONS'
+ else
+ rec_filename = 'DATA/STATIONS_ADJOINT'
+ endif
+ 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(nrec < 1) call exit_MPI(myrank,trim(STATIONS)//': need at least one receiver')
+
+
+ end subroutine initialize_simulation
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/intgrl.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/intgrl.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/intgrl.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/intgrl.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,192 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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
+ double precision, parameter :: third = 1.0d0/3.0d0
+ double precision, parameter :: fifth = 1.0d0/5.0d0
+ double precision, parameter :: sixth = 1.0d0/6.0d0
+
+ double precision rji,yprime(640)
+ double precision s1l,s2l,s3l
+
+ integer i,j,n,kdis(28)
+ integer ndis,nir1
+
+
+
+ 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)
+ s1l = s1(j)
+ s2l = s2(j)
+ s3l = s3(j)
+ sum = sum + r(j)*r(j)*rji*(f(j) &
+ + rji*(0.5d0*s1l + rji*(third*s2l + rji*0.25d0*s3l))) &
+ + 2.0d0*r(j)*rji*rji*(0.5d0*f(j) + rji*(third*s1l + rji*(0.25d0*s2l + rji*fifth*s3l))) &
+ + rji*rji*rji*(third*f(j) + rji*(0.25d0*s1l + rji*(fifth*s2l + rji*sixth*s3l)))
+ 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/src/lagrange_poly.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/lagrange_poly.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/lagrange_poly.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/lagrange_poly.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/lgndr.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/lgndr.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/lgndr.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/lgndr.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/locate_receivers.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/locate_receivers.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/locate_receivers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/locate_receivers.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,735 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!----
+!---- 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,stbur,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,stbur_found,epidist_found
+ character(len=150) STATIONS
+
+ integer, allocatable, dimension(:,:) :: ispec_selected_rec_all
+ double precision, dimension(nrec) :: stlat,stlon,stele,stbur
+ double precision, allocatable, dimension(:,:) :: xi_receiver_all,eta_receiver_all,gamma_receiver_all
+
+ character(len=150) OUTPUT_FILES
+ character(len=2) bic
+
+! **************
+
+! 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(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',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening STATIONS file')
+
+ ! loop on all the stations to read station information
+ do irec = 1,nrec
+ read(1,*,iostat=ier) station_name(irec),network_name(irec),stlat(irec),stlon(irec),stele(irec),stbur(irec)
+ if( ier /= 0 ) then
+ write(IMAIN,*) 'error reading in station ',irec
+ call exit_MPI(myrank,'error reading in station in STATIONS file')
+ endif
+ enddo
+ ! close receiver file
+ close(1)
+
+ ! if receivers can not be buried, sets depth to zero
+ if( .not. RECEIVERS_CAN_BE_BURIED ) stbur(:) = 0.d0
+
+ 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)
+ if(ASSUME_PERFECT_SPHERE) then
+ theta = PI/2.0d0 - stlat(irec)*PI/180.0d0
+ else
+ theta = PI/2.0d0 - atan(0.99329534d0*dtan(stlat(irec)*PI/180.0d0))
+ endif
+
+ 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)
+
+ if (myrank == 0) write(IOVTK,*) sngl(x_target(irec)), sngl(y_target(irec)), sngl(z_target(irec))
+
+! 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')
+ call band_instrument_code(DT,bic)
+
+ ! 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
+ 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),bic(1:2)//'N',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),bic(1:2)//'E',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),bic(1:2)//'Z',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
+ 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),bic(1:2)//'N',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),bic(1:2)//'E',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),bic(1:2)//'Z',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)
+ stbur_found(nrec_found) = stbur(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)
+ stbur(1:nrec) = stbur_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)
+
+ ! write out a filtered station list
+ if( NCHUNKS /= 6 ) then
+ open(unit=27,file=trim(OUTPUT_FILES)//'/STATIONS_FILTERED',status='unknown')
+ ! loop on all the stations to read station information
+ do irec = 1,nrec
+ write(27,'(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1)') trim(station_name(irec)),&
+ trim(network_name(irec)),sngl(stlat(irec)),&
+ sngl(stlon(irec)),sngl(stele(irec)),sngl(stbur(irec))
+ enddo
+ ! close receiver file
+ close(27)
+ endif
+
+
+
+! 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(stbur,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(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/src/locate_sources.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/locate_sources.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/locate_sources.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/locate_sources.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,926 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!----
+!---- 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,tshift_cmt,min_tshift_cmt_original,yr,jda,ho,mi,theta_source,phi_source, &
+ NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source, nu_source, &
+ rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION, &
+ LOCAL_PATH,SIMULATION_TYPE)
+
+ implicit none
+
+! 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
+
+ integer nspec,nglob,myrank
+
+ 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)
+
+ ! moment-tensor source parameters
+ double precision sec,min_tshift_cmt_original
+ double precision tshift_cmt(NSOURCES)
+ integer yr,jda,ho,mi
+ double precision, dimension(NSOURCES) :: theta_source,phi_source
+ double precision hdur(NSOURCES)
+ double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+
+ ! source locations
+ integer ispec_selected_source(NSOURCES)
+ integer islice_selected_source(NSOURCES)
+
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision nu_source(NDIM,NDIM,NSOURCES)
+
+ ! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ ! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ character(len=150) :: LOCAL_PATH
+ integer :: SIMULATION_TYPE
+
+! local parameters
+ integer isource
+ integer iprocloop
+ integer i,j,k,ispec,iglob
+ integer ier
+
+ double precision t0, hdur_gaussian(NSOURCES)
+
+ double precision ell
+ double precision elevation
+ double precision r0,dcost,p20
+ double precision theta,phi
+ 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
+
+ ! timer MPI
+ double precision time_start,tCPU
+
+ integer isources_already_done,isource_in_this_subset
+ 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, 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
+ integer :: 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
+ double precision, external :: comp_source_time_function_rickr
+
+! 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)
+ integer imin,imax,jmin,jmax,kmin,kmax
+ double precision :: f0,t0_ricker
+ double precision t_cmt_used(NSOURCES)
+
+! mask source region (mask values are between 0 and 1, with 0 around sources)
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable :: mask_source
+
+! **************
+
+! make sure we clean the future final array
+ ispec_selected_source(:) = 0
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! read all the sources
+ if(myrank == 0) call get_cmt(yr,jda,ho,mi,sec,tshift_cmt,hdur,lat,long,depth,moment_tensor, &
+ DT,NSOURCES,min_tshift_cmt_original)
+
+! 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(tshift_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)
+ call MPI_BCAST(min_tshift_cmt_original,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+! define topology of the control element
+ call hex_nodes(iaddx,iaddy,iaddr)
+
+! initializes source mask
+ if( SAVE_SOURCE_MASK .and. SIMULATION_TYPE == 3 ) then
+ allocate( mask_source(NGLLX,NGLLY,NGLLZ,NSPEC) )
+ mask_source(:,:,:,:) = 1.0_CUSTOM_REAL
+ endif
+
+! get MPI starting time for all sources
+ time_start = MPI_WTIME()
+
+! loop on all the sources
+! gather source information in subsets to reduce memory requirements
+
+! 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)
+ if(ASSUME_PERFECT_SPHERE) then
+ theta = PI/2.0d0 - lat(isource)*PI/180.0d0
+ else
+ theta = PI/2.0d0 - atan(0.99329534d0*dtan(lat(isource)*PI/180.0d0))
+ endif
+
+ 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)
+
+ if(myrank == 0) write(IOVTK,*) sngl(x_target_source),sngl(y_target_source),sngl(z_target_source)
+
+! set distance to huge initial value
+ distmin = HUGEVAL
+
+! compute typical size of elements at the surface
+ typical_size = TWO_PI * R_UNIT_SPHERE / (4.*NEX_XI)
+
+! use 10 times the distance as a criterion for source detection
+ typical_size = 10. * typical_size
+
+! flag to check that we located at least one target element
+ located_target = .false.
+
+ 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.
+
+ ! define the interval in which we look for points
+ if(USE_FORCE_POINT_SOURCE) then
+ ! force sources will be put on an exact GLL point
+ imin = 1
+ imax = NGLLX
+
+ jmin = 1
+ jmax = NGLLY
+
+ kmin = 1
+ kmax = NGLLZ
+
+ else
+ ! double-couple CMTSOLUTION
+ ! loop only on points inside the element
+ ! exclude edges to ensure this point is not shared with other elements
+ imin = 2
+ imax = NGLLX - 1
+
+ jmin = 2
+ jmax = NGLLY - 1
+
+ kmin = 2
+ kmax = NGLLZ - 1
+ endif
+ do k = kmin,kmax
+ do j = jmin,jmax
+ do i = imin,imax
+
+ ! keep this point if it is closer to the receiver
+ iglob = ibool(i,j,k,ispec)
+ dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
+ +(y_target_source - dble(ystore(iglob)))**2 &
+ +(z_target_source - dble(zstore(iglob)))**2)
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_source_subset(isource_in_this_subset) = ispec
+ ix_initial_guess_source = i
+ iy_initial_guess_source = j
+ iz_initial_guess_source = k
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! calculates a gaussian mask around source point
+ if( SAVE_SOURCE_MASK .and. SIMULATION_TYPE == 3 ) then
+ call calc_mask_source(mask_source,ispec,NSPEC,typical_size, &
+ x_target_source,y_target_source,z_target_source, &
+ ibool,xstore,ystore,zstore,NGLOB)
+ endif
+
+! 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
+
+ ! for point sources, the location will be exactly at a GLL point
+ ! otherwise this tries to find best location
+ if( USE_FORCE_POINT_SOURCE ) then
+ ! store xi,eta,gamma and x,y,z of point found
+ ! note: they have range [1.0d0,NGLLX/Y/Z], used for point sources
+ ! see e.g. in compute_add_sources.f90
+ xi_source_subset(isource_in_this_subset) = dble(ix_initial_guess_source)
+ eta_source_subset(isource_in_this_subset) = dble(iy_initial_guess_source)
+ gamma_source_subset(isource_in_this_subset) = dble(iz_initial_guess_source)
+
+ iglob = ibool(ix_initial_guess_source,iy_initial_guess_source, &
+ iz_initial_guess_source,ispec_selected_source_subset(isource_in_this_subset))
+ x_found_source(isource_in_this_subset) = xstore(iglob)
+ y_found_source(isource_in_this_subset) = ystore(iglob)
+ z_found_source(isource_in_this_subset) = zstore(iglob)
+
+ ! 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
+
+ else
+
+ ! 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
+
+ endif ! USE_FORCE_POINT_SOURCE
+
+! 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,*)
+ ! different output for force point sources
+ if(USE_FORCE_POINT_SOURCE) then
+ write(IMAIN,*) ' i index of source in that element: ',nint(xi_source(isource))
+ write(IMAIN,*) ' j index of source in that element: ',nint(eta_source(isource))
+ write(IMAIN,*) ' k index of source in that element: ',nint(gamma_source(isource))
+ write(IMAIN,*)
+ write(IMAIN,*) ' component direction: ',COMPONENT_FORCE_SOURCE
+ write(IMAIN,*)
+ write(IMAIN,*) ' nu1 = ',nu_source(1,:,isource)
+ write(IMAIN,*) ' nu2 = ',nu_source(2,:,isource)
+ write(IMAIN,*) ' nu3 = ',nu_source(3,:,isource)
+ write(IMAIN,*)
+ write(IMAIN,*) ' at (x,y,z) coordinates = ',x_found_source(isource_in_this_subset),&
+ y_found_source(isource_in_this_subset),z_found_source(isource_in_this_subset)
+
+ ! prints frequency content for point forces
+ f0 = hdur(isource)
+ t0_ricker = 1.2d0/f0
+ write(IMAIN,*) ' using a source of dominant frequency ',f0
+ write(IMAIN,*) ' lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ write(IMAIN,*) ' lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ write(IMAIN,*) ' t0_ricker = ',t0_ricker,'tshift_cmt = ',tshift_cmt(isource)
+ write(IMAIN,*)
+ write(IMAIN,*) ' half duration -> frequency: ',hdur(isource),' seconds**(-1)'
+ else
+ 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'
+ endif
+ write(IMAIN,*) ' time shift: ',tshift_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.)
+
+ ! define t0 as the earliest start time
+ ! note: this calculation here is only used for outputting the plot_source_time_function file
+ ! (see setup_sources_receivers.f90)
+ t0 = - 1.5d0*minval( tshift_cmt(:) - hdur(:) )
+ if( USE_FORCE_POINT_SOURCE ) t0 = - 1.2d0 * minval(tshift_cmt(:) - 1.0d0/hdur(:))
+ t_cmt_used(:) = t_cmt_used(:)
+ if( USER_T0 > 0.d0 ) then
+ if( t0 <= USER_T0 + min_tshift_cmt_original ) then
+ t_cmt_used(:) = tshift_cmt(:) + min_tshift_cmt_original
+ t0 = USER_T0
+ endif
+ endif
+ ! convert the half duration for triangle STF to the one for gaussian STF
+ ! note: this calculation here is only used for outputting the plot_source_time_function file
+ ! (see setup_sources_receivers.f90)
+ hdur_gaussian(:) = hdur(:)/SOURCE_DECAY_MIMIC_TRIANGLE
+
+ ! writes out source time function to file
+ do it=1,NSTEP
+ time_source = dble(it-1)*DT-t0-t_cmt_used(isource)
+ if( USE_FORCE_POINT_SOURCE ) then
+ ! Ricker source time function
+ f0 = hdur(isource)
+ write(27,*) sngl(dble(it-1)*DT-t0), &
+ sngl(FACTOR_FORCE_SOURCE*comp_source_time_function_rickr(time_source,f0))
+ else
+ ! Gaussian source time function
+ write(27,*) sngl(dble(it-1)*DT-t0), &
+ sngl(scalar_moment*comp_source_time_function(time_source,hdur_gaussian(isource)))
+ endif
+ enddo
+ close(27)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'printing the source spectrum'
+
+ ! print the spectrum of the derivative of the source from 0 to 1/8 Hz
+ if(NSOURCES == 1) then
+ plot_file = '/plot_source_spectrum.txt'
+ else
+ if(isource < 10) then
+ write(plot_file,"('/plot_source_spectrum',i1,'.txt')") isource
+ 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 !PRINT_SOURCE_TIME_FUNCTION
+
+ 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
+
+! stores source mask
+ if( SAVE_SOURCE_MASK .and. SIMULATION_TYPE == 3 ) then
+ call save_mask_source(myrank,mask_source,NSPEC,LOCAL_PATH)
+ deallocate( mask_source )
+ endif
+
+ end subroutine locate_sources
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine calc_mask_source(mask_source,ispec,NSPEC,typical_size, &
+ x_target_source,y_target_source,z_target_source, &
+ ibool,xstore,ystore,zstore,NGLOB)
+
+! calculate a gaussian function mask in the crust_mantle region
+! which is 0 around the source locations and 1 everywhere else
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: ispec,NSPEC,NGLOB
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: mask_source
+ real(kind=CUSTOM_REAL), dimension(NGLOB) :: xstore,ystore,zstore
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+
+ double precision :: typical_size
+ double precision :: x_target_source,y_target_source,z_target_source
+
+ ! local parameters
+ integer i,j,k,iglob
+ double precision dist_sq,sigma_sq
+
+ ! standard deviation for gaussian
+ ! (removes factor 10 added for search radius from typical_size)
+ sigma_sq = typical_size * typical_size / 100.0
+
+ ! loops over GLL points within this ispec element
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ ! gets distance (squared) to source
+ iglob = ibool(i,j,k,ispec)
+ dist_sq = (x_target_source - dble(xstore(iglob)))**2 &
+ +(y_target_source - dble(ystore(iglob)))**2 &
+ +(z_target_source - dble(zstore(iglob)))**2
+
+ ! adds gaussian function value to mask
+ ! (mask value becomes 0 closer to source location, 1 everywhere else )
+ mask_source(i,j,k,ispec) = mask_source(i,j,k,ispec) &
+ * ( 1.0_CUSTOM_REAL - exp( - dist_sq / sigma_sq ) )
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine calc_mask_source
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine save_mask_source(myrank,mask_source,NSPEC,LOCAL_PATH)
+
+! saves a mask in the crust_mantle region which is 0 around the source locations
+! and 1 everywhere else
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: myrank,NSPEC
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: mask_source
+ character(len=150) :: LOCAL_PATH
+
+ ! local parameters
+ character(len=150) :: prname
+
+ ! stores into file
+ call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
+ open(unit=27,file=trim(prname)//'mask_source.bin',status='unknown',form='unformatted',action='write')
+ write(27) mask_source
+ close(27)
+
+ end subroutine save_mask_source
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/make_ellipticity.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/make_ellipticity.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/make_ellipticity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/make_ellipticity.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/make_gravity.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/make_gravity.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/make_gravity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/make_gravity.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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 ! PREM moho depth at 24.4 km
+ 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/src/memory_eval.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/memory_eval.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/memory_eval.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/memory_eval.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,359 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute the 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
+! note: the number of transverse isotropic elements is ispec_aniso
+! however for transverse isotropic kernels, the arrays muhstore,kappahstore,eta_anisostore,
+! will be needed for the crust_mantle region everywhere still...
+! originally: NSPECMAX_TISO_MANTLE = ispec_aniso
+ NSPECMAX_TISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
+ 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 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD)) ) 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
+! rhostore_outer_core,kappavstore_outer_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*11.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)
+
+! rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ISO_MANTLE*3.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,
+! rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_INNER_CORE)*12.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)
+
+! updated_dof_ocean_load
+ static_memory_size = static_memory_size + NGLOB(IREGION_CRUST_MANTLE)*dble(SIZE_LOGICAL)
+
+ 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/src/meshfem3D.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1246 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ program xmeshfem3D
+
+ use meshfem3D_models_par
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ !include "constants.h"
+ include "precision.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 at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @INCOLLECTION{ChKoViCaVaFe07,
+! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
+! Yann Capdeville and Bernard Valette and Gaetano Festa},
+! title = {Spectral Element Analysis in Seismology},
+! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
+! publisher = {Elsevier - Academic Press},
+! year = {2007},
+! editor = {Ru-Shan Wu and Val\'erie Maupin},
+! volume = {48},
+! series = {Advances in Geophysics},
+! pages = {365-419}}
+!
+! @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}}
+!
+! @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{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}}
+!
+! and/or another article from http://web.univ-pau.fr/~dkomati1/publications.html
+!
+!
+! If you use the kernel capabilities of the code, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! If you use 3-D model S20RTS, please cite:
+!
+! @ARTICLE{RiVa00,
+! author={J. Ritsema and H. J. {Van Heijst}},
+! year=2000,
+! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
+! journal={Science Progress},
+! volume=83,
+! pages={243-259}}
+!
+! Reference frame - convention:
+! ----------------------------
+!
+! The code uses the following convention for the reference frame:
+!
+! - X axis is East
+! - Y axis is North
+! - Z axis is up
+!
+! Note that this convention is different from both the Aki-Richards convention
+! and the Harvard CMT convention.
+!
+! Let us recall that the Aki-Richards convention is:
+!
+! - X axis is North
+! - Y axis is East
+! - Z axis is down
+!
+! and that the Harvard CMT convention is:
+!
+! - X axis is South
+! - Y axis is East
+! - Z axis is up
+!
+! To report bugs or suggest improvements to the code, please send an email
+! to Jeroen Tromp <jtromp AT princeton.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+! Evolution of the code:
+! ---------------------
+!
+! v. 5.1, Dimitri Komatitsch, University of Toulouse, France and Ebru Bozdag, Princeton University, USA, February 2011:
+! non blocking MPI for much better scaling on large clusters;
+! new convention for the name of seismograms, to conform to the IRIS standard;
+! new directory structure
+!
+! v. 5.0 aka Tiger, many developers some with Princeton Tiger logo on their shirts, February 2010:
+! new moho mesh stretching honoring crust2.0 moho depths,
+! new attenuation assignment, new SAC headers, new general crustal models,
+! faster performance due to Deville routines and enhanced loop unrolling,
+! slight changes in code structure
+!
+! 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, one more doubling level at the bottom
+! of the outer core if needed (off by default)
+!
+! 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 CM-5 Connection Machine
+!
+! 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.
+
+
+! 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
+ 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
+
+! check area and volume of the final mesh
+ double precision area_local_bottom
+ double precision area_local_top
+ double precision volume_local,volume_total
+
+ !integer iprocnum
+
+! for loop on all the slices
+ integer iregion_code
+ integer iproc_xi,iproc_eta,ichunk
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! 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, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ RMOHO_FICTITIOUS_IN_MESHER
+
+ logical MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,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
+
+ 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
+
+! 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
+
+ integer :: ipass
+
+ 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
+
+! this for non blocking MPI
+ logical, dimension(:), allocatable :: is_on_a_slice_edge
+
+! ************** PROGRAM STARTS HERE **************
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+! trivia about the programming style adopted here
+!
+! note 1: in general, we do not use modules in the fortran codes. this seems to
+! be mainly a performance reason. changing the codes to adopt modules
+! will have to prove that it performs as fast as it does without now.
+!
+! another reason why modules are avoided, is to make the code thread safe.
+! having different threads access the same data structure and modifying it at the same time
+! would lead to problems. passing arguments is a way to avoid such complications.
+!
+! however, the mesher makes one exception here: it uses the
+! module "meshfem3D_models_par" defined in the 'meshfem3D_models.f90' file.
+! the exception is based on the fact, that when one wants to incorporate
+! a new 3D/1D velocity model, it became tedious to change so many routines hardly
+! related to any model specific need.
+!
+! note 2: adding a new velocity model should become easier. the module tries to help with
+! that task. basically, you would follow the comments "ADD YOUR MODEL HERE"
+! to have an idea where you will have to put some new code:
+!
+! - meshfem3D_models.f90: main file for models
+! put your model structure into the module "meshfem3D_models_par"
+! and add your specific routine calls to get 1D/3D/attenuation values.
+!
+! - get_model_parameters.f90:
+! set your specific model flags and radii
+!
+! - read_compute_parameters.f90:
+! some models need to explicitly set smaller time steps which
+! can be done in routine rcp_set_timestep_and_layers()
+!
+! - add your model implementation into a new file named model_***.f90:
+! in general, this file should have as first routine the model_***_broadcast() routine
+! implemented which deals with passing the model structure to all processes.
+! this involves reading in model specific data which is normally put in directory DATA/
+! then follows a routine that returns the velocity values
+! (as perturbation to the associated 1D reference model) for a given point location.
+!
+! finally, in order to compile the new mesher with your new file(s),
+! you will add it to the list in the 'Makefile.in' file and run
+! `configure` to recreate a new Makefile.
+!
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+! 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
+ ! reads the parameter file and computes additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,&
+ this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube, &
+ HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE, &
+ USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
+
+ if(err_occurred() /= 0) &
+ call exit_MPI(myrank,'an error occurred while reading the parameter file')
+
+ endif
+
+ ! distributes parameters from master to all processes
+ call broadcast_compute_parameters(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ RMOHO_FICTITIOUS_IN_MESHER, &
+ MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
+ OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
+ LOCAL_PATH,MODEL, &
+ 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, &
+ ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
+ HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
+ ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY)
+
+ ! check that the code is running with the requested number of processes
+ if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
+
+ ! 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)
+
+ ! dynamic allocation of mesh arrays
+ allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1))
+ allocate(ichunk_slice(0:NPROCTOT-1))
+ allocate(iproc_xi_slice(0:NPROCTOT-1))
+ allocate(iproc_eta_slice(0:NPROCTOT-1))
+
+ ! creates global slice addressing for solver
+ call meshfem3D_create_addressing(myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT, &
+ addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
+ OUTPUT_FILES)
+
+
+ ! this for the different counters (which are now different if the superbrick is cut in the outer core)
+ call meshfem3D_setup_counters(myrank, &
+ NSPEC1D_RADIAL,NSPEC2D_XI,NSPEC2D_ETA,NGLOB1D_RADIAL, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ NPROCTOT,iproc_xi_slice,iproc_eta_slice, &
+ NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE, &
+ NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
+
+ ! user output
+ if(myrank == 0) call meshfem3D_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT, &
+ R_CENTRAL_CUBE)
+
+ ! distributes 3D models
+ call meshfem3D_models_broadcast(myrank,NSPEC, &
+ MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,&
+ R80,R220,R670,RCMB,RICB)
+
+
+ if(myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'model setup successfully read in'
+ write(IMAIN,*)
+ endif
+
+ ! get addressing for this process
+ ichunk = ichunk_slice(myrank)
+ iproc_xi = iproc_xi_slice(myrank)
+ iproc_eta = iproc_eta_slice(myrank)
+
+ ! 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
+!----
+
+ ! 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
+ allocate(idoubling(NSPEC(iregion_code)))
+ allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
+ allocate(xstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
+ allocate(ystore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
+ allocate(zstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
+
+! this for non blocking MPI
+ allocate(is_on_a_slice_edge(NSPEC(iregion_code)))
+
+ ! create all the regions of the mesh
+ ! perform two passes in this part to be able to save memory
+ do ipass = 1,2
+
+ call create_regions_mesh(iregion_code,ibool,idoubling,is_on_a_slice_edge, &
+ xstore,ystore,zstore,rmins,rmaxs, &
+ iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_aniso, &
+ volume_local,area_local_bottom,area_local_top, &
+ 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), &
+ NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE, &
+ NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+ myrank,LOCAL_PATH,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
+ SAVE_MESH_FILES,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
+ R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
+ 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,ipass,ratio_divide_central_cube, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2))
+
+ enddo
+
+ ! 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')
+
+ ! computes total area and volume
+ call meshfem3D_compute_area(myrank,NCHUNKS,iregion_code, &
+ area_local_bottom,area_local_top,&
+ volume_local,volume_total, &
+ RCMB,RICB,R_CENTRAL_CUBE)
+
+ ! create chunk buffers if more than one chunk
+ if(NCHUNKS > 1) then
+ call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool,idoubling, &
+ 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)
+ 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
+ deallocate(idoubling)
+ deallocate(ibool)
+ deallocate(xstore)
+ deallocate(ystore)
+ deallocate(zstore)
+
+! this for non blocking MPI
+ deallocate(is_on_a_slice_edge)
+
+ ! make sure everybody is synchronized
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! end of loop on all the regions
+ enddo
+
+ if(myrank == 0) then
+ ! check volume of chunk
+ write(IMAIN,*)
+ write(IMAIN,*) 'calculated volume: ',volume_total
+ if(.not. TOPOGRAPHY) then
+ ! take the central cube into account
+ ! it is counted 6 times because of the fictitious elements
+ if(INCLUDE_CENTRAL_CUBE) then
+ write(IMAIN,*) ' exact volume: ', &
+ dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)+5.*(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
+ else
+ write(IMAIN,*) ' exact volume: ', &
+ dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)-(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
+ endif
+ endif
+ endif
+
+
+!--- print number of points and elements in the mesh for each region
+
+ if(myrank == 0) then
+
+ numelem_crust_mantle = NSPEC(IREGION_CRUST_MANTLE)
+ numelem_outer_core = NSPEC(IREGION_OUTER_CORE)
+ numelem_inner_core = NSPEC(IREGION_INNER_CORE)
+
+ numelem_total = numelem_crust_mantle + numelem_outer_core + numelem_inner_core
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Repartition of elements in regions:'
+ write(IMAIN,*) '----------------------------------'
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of elements in each slice: ',numelem_total
+ write(IMAIN,*)
+ write(IMAIN,*) ' - crust and mantle: ',sngl(100.d0*dble(numelem_crust_mantle)/dble(numelem_total)),' %'
+ write(IMAIN,*) ' - outer core: ',sngl(100.d0*dble(numelem_outer_core)/dble(numelem_total)),' %'
+ write(IMAIN,*) ' - inner core: ',sngl(100.d0*dble(numelem_inner_core)/dble(numelem_total)),' %'
+ write(IMAIN,*)
+ write(IMAIN,*) 'for some mesh statistics, see comments in file OUTPUT_FILES/values_from_mesher.h'
+ write(IMAIN,*)
+
+ ! load balancing
+ write(IMAIN,*) 'Load balancing = 100 % by definition'
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'time-stepping of the solver will be: ',DT
+ write(IMAIN,*)
+
+ ! write information about precision used for floating-point operations
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IMAIN,*) 'using single precision for the calculations'
+ else
+ write(IMAIN,*) 'using double precision for the calculations'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
+ write(IMAIN,*)
+
+ ! 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,OCEANS,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, &
+ SIMULATION_TYPE,SAVE_FORWARD,MOVIE_VOLUME,NOISE_TOMOGRAPHY)
+
+ endif ! end of section executed by main process only
+
+ ! deallocate arrays used for mesh generation
+ 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)
+
+ ! stop all the MPI processes, and exit
+ call MPI_FINALIZE(ier)
+
+ end program xmeshfem3D
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine meshfem3D_create_addressing(myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT, &
+ addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
+ OUTPUT_FILES)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT
+
+ integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
+ integer, dimension(0:NPROCTOT-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
+
+ character(len=150) OUTPUT_FILES
+
+ ! local parameters
+ integer ichunk,iproc_eta,iproc_xi,iprocnum,ier
+
+ ! initializes
+ 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
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/addressing.txt',status='unknown',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening addressing.txt')
+ 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
+ if(myrank == 0) write(IOUT,*) iprocnum,ichunk,iproc_xi,iproc_eta
+ enddo
+ enddo
+ enddo
+
+ if(myrank == 0) close(IOUT)
+
+ end subroutine meshfem3D_create_addressing
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine meshfem3D_setup_counters(myrank, &
+ NSPEC1D_RADIAL,NSPEC2D_XI,NSPEC2D_ETA,NGLOB1D_RADIAL, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ NPROCTOT,iproc_xi_slice,iproc_eta_slice, &
+ NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE, &
+ NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
+
+! returns: NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE,
+! NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL
+
+ 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
+
+ ! addressing for all the slices
+ integer :: NPROCTOT
+ integer, dimension(0:NPROCTOT-1) :: iproc_xi_slice,iproc_eta_slice
+
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+
+! 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
+
+
+ ! local parameters
+ integer :: iregion
+
+ 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
+
+ end subroutine meshfem3D_setup_counters
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine meshfem3D_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT,&
+ R_CENTRAL_CUBE)
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer :: myrank,sizeprocs,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT
+ double precision :: R_CENTRAL_CUBE
+
+ 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,*)
+ 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(HETEROGEN_3D_MANTLE) then
+ write(IMAIN,*) 'incorporating heterogeneities in the mantle'
+ else
+ write(IMAIN,*) 'no heterogeneities in the mantle'
+ 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,*)
+ if(ANISOTROPIC_INNER_CORE) then
+ write(IMAIN,*) 'incorporating anisotropic inner core'
+ else
+ write(IMAIN,*) 'no inner-core anisotropy'
+ endif
+ write(IMAIN,*)
+ if(ANISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) 'incorporating anisotropic mantle'
+ else
+ write(IMAIN,*) 'no general mantle anisotropy'
+ endif
+ write(IMAIN,*)
+ 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'
+
+ end subroutine meshfem3D_output_info
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine meshfem3D_compute_area(myrank,NCHUNKS,iregion_code, &
+ area_local_bottom,area_local_top,&
+ volume_local,volume_total, &
+ RCMB,RICB,R_CENTRAL_CUBE)
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ include 'mpif.h'
+
+ integer :: myrank,NCHUNKS,iregion_code
+
+ double precision :: area_local_bottom,area_local_top,volume_local
+ double precision :: volume_total
+ double precision :: RCMB,RICB,R_CENTRAL_CUBE
+
+ ! local parameters
+ double precision :: volume_total_region,area_total_bottom,area_total_top
+ integer :: ier
+
+ ! 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,*) ' similar 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
+
+
+ end subroutine meshfem3D_compute_area
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D_models.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D_models.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D_models.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D_models.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1381 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ module meshfem3D_models_par
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ implicit none
+
+ include "constants.h"
+
+! model_aniso_mantle_variables
+ type model_aniso_mantle_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ integer dummy_pad ! padding 4 bytes to align the structure
+ end type model_aniso_mantle_variables
+ type (model_aniso_mantle_variables) AMM_V
+! model_aniso_mantle_variables
+
+! model_attenuation_variables
+ type model_attenuation_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
+ 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, dimension(:), pointer :: interval_Q ! Steps
+ integer :: Qn ! Number of points
+ integer dummy_pad ! padding 4 bytes to align the structure
+ end type model_attenuation_variables
+ type (model_attenuation_variables) AM_V
+! model_attenuation_variables
+
+! model_atten3D_QRFSI12_variables
+ type model_atten3D_QRFSI12_variables
+ sequence
+ double precision dqmu(NKQ,NSQ)
+ double precision spknt(NKQ)
+ double precision refdepth(NDEPTHS_REFQ)
+ double precision refqmu(NDEPTHS_REFQ)
+ end type model_atten3D_QRFSI12_variables
+ type (model_atten3D_QRFSI12_variables) QRFSI12_Q
+! model_atten3D_QRFSI12_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_1dref_variables
+ type model_1dref_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_1dref_variables
+ type (model_1dref_variables) Mref_V
+! model_1dref_variables
+
+! model_sea1d_variables
+ type model_sea1d_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 model_sea1d_variables
+ type (model_sea1d_variables) SEA1DM_V
+! model_sea1d_variables
+
+! model_s20rts_variables
+ type model_s20rts_variables
+ sequence
+ double precision dvs_a(0:NK_20,0:NS_20,0:NS_20) !a = positive m (radial, theta, phi) --> (k,l,m) (maybe other way around??)
+ double precision dvs_b(0:NK_20,0:NS_20,0:NS_20) !b = negative m (radial, theta, phi) --> (k,l,-m)
+ double precision dvp_a(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvp_b(0:NK_20,0:NS_20,0:NS_20)
+ double precision spknt(NK_20+1)
+ double precision qq0(NK_20+1,NK_20+1)
+ double precision qq(3,NK_20+1,NK_20+1)
+ end type model_s20rts_variables
+ type (model_s20rts_variables) S20RTS_V
+! model_s20rts_variables
+
+! model_s40rts_variables
+ type model_s40rts_variables
+ sequence
+ double precision dvs_a(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvs_b(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvp_a(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvp_b(0:NK_20,0:NS_40,0:NS_40)
+ double precision spknt(NK_20+1)
+ double precision qq0(NK_20+1,NK_20+1)
+ double precision qq(3,NK_20+1,NK_20+1)
+ end type model_s40rts_variables
+ type (model_s40rts_variables) S40RTS_V
+! model_s40rts_variables
+
+! model_heterogen_m_variables
+ type model_heterogen_m_variables
+ sequence
+ double precision rho_in(N_R*N_THETA*N_PHI)
+ end type model_heterogen_m_variables
+ type (model_heterogen_m_variables) HMM
+! model_heterogen_m_variables
+
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_variables
+
+! model_sea99_s_variables
+ type model_sea99_s_variables
+ sequence
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_sea99_s_variables
+ type (model_sea99_s_variables) SEA99M_V
+! model_sea99_s_variables
+
+! crust 2.0 model_crust_variables
+ type model_crust_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)
+ character(len=2) dummy_pad ! padding 2 bytes to align the structure
+ end type model_crust_variables
+ type (model_crust_variables) CM_V
+! model_crust_variables
+
+! EUcrust
+ type model_eucrust_variables
+ sequence
+ double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
+ eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
+ eucrust_basement,eucrust_ucdepth
+ integer :: num_eucrust
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_eucrust_variables
+ type (model_eucrust_variables) EUCM_V
+
+! model_crustmaps_variables combined crustal maps
+ type model_crustmaps_variables
+ sequence
+ double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
+ double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
+ double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
+ double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
+ double precision thicknessnp(NLAYERS_CRUSTMAP)
+ double precision densitynp(NLAYERS_CRUSTMAP)
+ double precision velocpnp(NLAYERS_CRUSTMAP)
+ double precision velocsnp(NLAYERS_CRUSTMAP)
+ double precision thicknesssp(NLAYERS_CRUSTMAP)
+ double precision densitysp(NLAYERS_CRUSTMAP)
+ double precision velocpsp(NLAYERS_CRUSTMAP)
+ double precision velocssp(NLAYERS_CRUSTMAP)
+ end type model_crustmaps_variables
+ type (model_crustmaps_variables) GC_V
+!model_crustmaps_variables
+
+! model_attenuation_storage_var
+ type model_attenuation_storage_var
+ sequence
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ integer Q_resolution
+ integer Q_max
+ end type model_attenuation_storage_var
+ type (model_attenuation_storage_var) AM_S
+! model_attenuation_storage_var
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ 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
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ end type attenuation_simplex_variables
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+! point profile model_variables
+ type model_ppm_variables
+ sequence
+ double precision,dimension(:),pointer :: dvs,lat,lon,depth
+ double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
+ double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
+ integer :: num_v,num_latperlon,num_lonperdepth
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_ppm_variables
+ type (model_ppm_variables) PPM_V
+
+! GLL model_variables
+ type model_gll_variables
+ sequence
+ ! tomographic iteration model on GLL points
+ double precision :: scale_velocity,scale_density
+ ! isotropic model
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vs_new,vp_new,rho_new
+ ! transverse isotropic model
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vsv_new,vpv_new, &
+ vsh_new,vph_new,eta_new
+ logical :: MODEL_GLL
+ logical,dimension(3) :: dummy_pad ! padding 3 bytes to align the structure
+ end type model_gll_variables
+ type (model_gll_variables) MGLL_V
+
+! bathymetry and topography: use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! used for 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ 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)
+
+ 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)
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+
+ character(len=80) kerstr
+ character(len=80) refmdl
+ character(len=40) varstr(maxker)
+ character(len=80) hsplfl(maxhpa)
+ character(len=40) dskker(maxker)
+
+
+! for ellipticity
+ double precision rspl(NR),espl(NR),espl2(NR)
+ integer nspl
+
+! model parameter and flags
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS
+
+ logical HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY
+
+ logical ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE
+
+ logical ATTENUATION,ATTENUATION_3D
+
+ logical ANISOTROPIC_INNER_CORE
+
+ end module meshfem3D_models_par
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine meshfem3D_models_broadcast(myrank,NSPEC, &
+ MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,&
+ R80,R220,R670,RCMB,RICB)
+
+! preparing model parameter coefficients on all processes
+
+ use meshfem3D_models_par
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer myrank
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC
+
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
+
+ double precision R80,R220,R670,RCMB,RICB
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ ! sets up spline coefficients for ellipticity
+ if(ELLIPTICITY) &
+ call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
+
+ ! GLL model uses s29ea as reference 3D model
+ if( THREE_D_MODEL == THREE_D_MODEL_GLL ) then
+ MGLL_V%MODEL_GLL = .true.
+ THREE_D_MODEL = THREE_D_MODEL_S29EA
+ else
+ MGLL_V%MODEL_GLL = .false.
+ endif
+
+ ! reads in 3D mantle models
+ if(ISOTROPIC_3D_MANTLE) then
+
+ select case( THREE_D_MODEL )
+
+ case(THREE_D_MODEL_S20RTS)
+ call model_s20rts_broadcast(myrank,S20RTS_V)
+
+ case(THREE_D_MODEL_S40RTS)
+ call model_s40rts_broadcast(myrank,S40RTS_V)
+
+ case(THREE_D_MODEL_SEA99_JP3D)
+ ! the variables read are declared and stored in structure SEA99M_V and JP3DM_V
+ call model_sea99_s_broadcast(myrank,SEA99M_V)
+ call model_jp3d_broadcast(myrank,JP3DM_V)
+
+ case(THREE_D_MODEL_SEA99)
+ ! the variables read are declared and stored in structure SEA99M_V
+ call model_sea99_s_broadcast(myrank,SEA99M_V)
+
+ case(THREE_D_MODEL_JP3D)
+ ! the variables read are declared and stored in structure JP3DM_V
+ call model_jp3d_broadcast(myrank,JP3DM_V)
+
+ case(THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
+ THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA)
+ call model_s362ani_broadcast(myrank,THREE_D_MODEL,numker,numhpa,ihpa,&
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
+ xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
+
+ case(THREE_D_MODEL_PPM)
+ ! Point Profile Models
+ ! the variables read are declared and stored in structure PPM_V
+ call model_ppm_broadcast(myrank,PPM_V)
+
+ ! could use EUcrust07 Vp crustal structure
+ !call model_eucrust_broadcast(myrank,EUCM_V)
+
+ case(THREE_D_MODEL_GAPP2)
+ ! GAP model
+ call model_gapp2_broadcast(myrank)
+
+ case default
+ call exit_MPI(myrank,'3D model not defined')
+
+ end select
+
+ endif
+
+ ! arbitrary mantle models
+ if(HETEROGEN_3D_MANTLE) &
+ call model_heterogen_mntl_broadcast(myrank,HMM)
+
+ ! anisotropic mantle
+ if(ANISOTROPIC_3D_MANTLE) &
+ call model_aniso_mantle_broadcast(myrank,AMM_V)
+
+ ! crustal model
+ if(CRUSTAL) &
+ call meshfem3D_crust_broadcast(myrank)
+
+ ! GLL model
+ if( MGLL_V%MODEL_GLL ) &
+ call model_gll_broadcast(myrank,MGLL_V,NSPEC)
+
+ ! attenuation
+ if(ATTENUATION ) then
+ call model_attenuation_broadcast(myrank,AM_V,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD)
+
+ ! 3D attenuation
+ if( ATTENUATION_3D) then
+ ! Colleen's model defined originally between 24.4km and 650km
+ call model_atten3D_QRFSI12_broadcast(myrank,QRFSI12_Q)
+ else
+ ! sets up attenuation coefficients according to the chosen, "pure" 1D model
+ ! (including their 1D-crustal profiles)
+ call model_attenuation_setup(REFERENCE_1D_MODEL, RICB, RCMB, &
+ R670, R220, R80,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,AM_S,AS_V)
+ endif
+
+ endif
+
+ ! read topography and bathymetry file
+ if(TOPOGRAPHY .or. OCEANS) &
+ call model_topo_bathy_broadcast(myrank,ibathy_topo)
+
+ ! re-defines/initializes models 1066a and ak135 and ref
+ ! ( with possible external crustal model: if CRUSTAL is set to true
+ ! it strips the 1-D crustal profile and replaces it with mantle properties)
+ select case( REFERENCE_1D_MODEL )
+
+ case(REFERENCE_MODEL_1066A)
+ call model_1066a_broadcast(CRUSTAL,M1066a_V)
+
+ case( REFERENCE_MODEL_AK135)
+ call model_ak135_broadcast(CRUSTAL,Mak135_V)
+
+ case(REFERENCE_MODEL_1DREF)
+ call model_1dref_broadcast(CRUSTAL,Mref_V)
+
+ case(REFERENCE_MODEL_SEA1D)
+ call model_sea1d_broadcast(CRUSTAL,SEA1DM_V)
+
+ end select
+
+ end subroutine meshfem3D_models_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine meshfem3D_crust_broadcast(myrank)
+
+! preparing model parameter coefficients on all processes
+
+ use meshfem3D_models_par
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer myrank
+
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ select case (ITYPE_CRUSTAL_MODEL )
+
+ case (ICRUST_CRUST2)
+ ! crust 2.0
+ call model_crust_broadcast(myrank,CM_V)
+
+ case (ICRUST_CRUSTMAPS)
+ ! general crustmaps
+ call model_crustmaps_broadcast(myrank,GC_V)
+
+ case default
+ stop 'crustal model type not defined'
+
+ end select
+
+
+ end subroutine meshfem3D_crust_broadcast
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine meshfem3D_models_get1D_val(myrank,iregion_code,idoubling, &
+ r_prem,rho,vpv,vph,vsv,vsh,eta_aniso, &
+ Qkappa,Qmu,RICB,RCMB, &
+ RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
+ RMOHO,RMIDDLE_CRUST,ROCEAN)
+! reference model values
+!
+! for a given location radius (r_prem, which is the point's radius with tolerance factor),
+! this calculates density and velocities
+!
+! note: if CRUSTAL is set, it strips the 1-D crustal profile and mantle gets expanded
+! up to the surface.
+! only exception is JP1D...
+!
+! routine returns: rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer myrank,iregion_code,idoubling
+ double precision r_prem,rho
+ double precision vpv,vph,vsv,vsh,eta_aniso
+ double precision Qkappa,Qmu
+ double precision RICB,RCMB,RTOPDDOUBLEPRIME,R80,R120,R220,R400, &
+ R600,R670,R771,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ ! local parameters
+ double precision drhodr,vp,vs
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ ! gets 1-D reference model parameters
+ select case ( REFERENCE_1D_MODEL )
+
+ case(REFERENCE_MODEL_PREM)
+ ! PREM (by Dziewonski & Anderson) - used also as background for 3D models
+ if(TRANSVERSE_ISOTROPY) then
+ ! get the anisotropic PREM parameters
+ call model_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
+ ! isotropic model
+ call model_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)
+ endif
+
+ case(REFERENCE_MODEL_1DREF)
+ ! 1D-REF also known as STW105 (by Kustowski et al.) - used also as background for 3D models
+ call model_1dref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
+ if(.not. TRANSVERSE_ISOTROPY) then
+ if(.not. ISOTROPIC_3D_MANTLE) then
+ ! this case here is only executed for 1D_ref_iso
+ ! calculates isotropic values
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
+ + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
+ + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+ endif
+ endif
+
+ case(REFERENCE_MODEL_1066A)
+ ! 1066A (by Gilbert & Dziewonski) - pure isotropic model, used in 1D model mode only
+ call model_1066a(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V)
+
+ case(REFERENCE_MODEL_AK135)
+ ! AK135 (by Kennett et al. ) - pure isotropic model, used in 1D model mode only
+ call model_ak135(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V)
+
+ case(REFERENCE_MODEL_IASP91)
+ ! IASP91 (by Kennett & Engdahl) - pure isotropic model, used in 1D model mode only
+ 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)
+
+ case(REFERENCE_MODEL_JP1D)
+ !JP1D (by Zhao et al.) - pure isotropic model, used also as background for 3D models
+ call model_jp1d(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
+ .true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
+
+ case(REFERENCE_MODEL_SEA1D)
+ ! SEA1D (by Lebedev & Nolet) - pure isotropic model, used also as background for 3D models
+ call model_sea1d(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
+
+ case default
+ stop 'unknown 1D reference Earth model in meshfem3D_models_get1D_val()'
+
+ end select
+
+ ! needs to set vpv,vph,vsv,vsh and eta_aniso for isotropic models
+ if( .not. TRANSVERSE_ISOTROPY ) then
+ ! in the case of s362iso we want to save the anisotropic constants for the Voight average
+ if(.not. (REFERENCE_1D_MODEL == REFERENCE_MODEL_1DREF .and. ISOTROPIC_3D_MANTLE)) then
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ eta_aniso = 1.d0
+ endif
+ endif ! TRANSVERSE_ISOTROPY
+
+ end subroutine meshfem3D_models_get1D_val
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine meshfem3D_models_get3Dmntl_val(iregion_code,r_prem,rho,dvp,&
+ vpv,vph,vsv,vsh,eta_aniso, &
+ RCMB,R670,RMOHO, &
+ xmesh,ymesh,zmesh,r, &
+ c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer iregion_code
+ double precision r_prem
+ double precision rho,dvp
+ double precision vpv,vph,vsv,vsh,eta_aniso
+
+ double precision RCMB,R670,RMOHO
+ double precision xmesh,ymesh,zmesh,r
+
+ ! 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
+
+ ! local parameters
+ double precision :: r_used,r_dummy,theta,phi
+ double precision :: dvs,drho,vp,vs
+ real(kind=4) :: xcolat,xlon,xrad,dvpv,dvph,dvsv,dvsh
+ logical :: found_crust,suppress_mantle_extension
+
+ ! initializes perturbation values
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ dvpv = 0.
+ dvph = 0.
+ dvsv = 0.
+ dvsh = 0.
+ r_used = ZERO
+ suppress_mantle_extension = .false.
+
+ ! gets point's theta/phi
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ ! sets flag when mantle should not be extended to surface
+ if(r_prem >= RMOHO/R_EARTH .and. .not. CRUSTAL) then
+ suppress_mantle_extension = .true.
+ endif
+
+ ! gets parameters for isotropic 3D mantle model
+ !
+ ! note: there can be tranverse isotropy in the mantle, but only lamé parameters
+ ! like kappav,kappah,muv,muh and eta_aniso are used for these simulations
+ !
+ ! note: in general, models here make use of perturbation values with respect to their
+ ! corresponding 1-D reference models
+ if( ISOTROPIC_3D_MANTLE .and. r_prem > RCMB/R_EARTH .and. .not. suppress_mantle_extension) then
+
+ ! extend 3-D mantle model above the Moho to the surface before adding the crust
+ if(r_prem > RCMB/R_EARTH .and. r_prem < RMOHO/R_EARTH) then
+ ! GLL point is in mantle region, takes exact location
+ r_used = r
+ else ! else if(r_prem >= RMOHO/R_EARTH) then
+ if( CRUSTAL ) then
+ ! GLL point is above moho
+ ! takes radius slightly below moho radius, this will then "extend the mantle up to the surface";
+ ! crustal values will be superimposed later on
+ r_used = 0.999999d0*RMOHO/R_EARTH
+ endif
+ endif
+
+ ! gets model parameters
+ select case( THREE_D_MODEL )
+
+ case(THREE_D_MODEL_S20RTS)
+ ! s20rts
+ call mantle_s20rts(r_used,theta,phi,dvs,dvp,drho,S20RTS_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)
+
+ case(THREE_D_MODEL_S40RTS)
+ ! s40rts
+ call mantle_s40rts(r_used,theta,phi,dvs,dvp,drho,S40RTS_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)
+
+ case(THREE_D_MODEL_SEA99_JP3D)
+ ! sea99 + jp3d1994
+ call model_sea99_s(r_used,theta,phi,dvs,SEA99M_V)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ ! use Lebedev model sea99 as background and add vp & vs perturbation from Zhao 1994 model jp3d
+ 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_used > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call model_jp3d_iso_zhao(r_used,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
+
+ case(THREE_D_MODEL_SEA99)
+ ! sea99 Vs-only
+ call model_sea99_s(r_used,theta,phi,dvs,SEA99M_V)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+
+ case(THREE_D_MODEL_JP3D)
+ ! jp3d1994
+ 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_used > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call model_jp3d_iso_zhao(r_used,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
+
+ case(THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
+ THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA)
+ ! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ xcolat = sngl(theta*180.0d0/PI)
+ xlon = sngl(phi*180.0d0/PI)
+ xrad = sngl(r_used*R_EARTH_KM)
+ call model_s362ani_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
+
+ case(THREE_D_MODEL_PPM )
+ ! point profile model
+ call model_PPM(r_used,theta,phi,dvs,dvp,drho,PPM_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)
+
+ case(THREE_D_MODEL_GAPP2 )
+ ! 3D GAP model (Obayashi)
+ call mantle_gapmodel(r_used,theta,phi,dvs,dvp,drho)
+ 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)
+
+ case default
+ stop 'unknown 3D Earth model in meshfem3D_models_get3Dmntl_val() '
+
+ end select ! THREE_D_MODEL
+
+ endif ! ISOTROPIC_3D_MANTLE
+
+ ! heterogen model
+ if( HETEROGEN_3D_MANTLE .and. .not. suppress_mantle_extension ) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_used,theta,phi)
+ call reduce(theta,phi)
+ call model_heterogen_mantle(r_used,theta,phi,dvs,dvp,drho,HMM)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vpv*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ endif ! HETEROGEN_3D_MANTLE
+
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) &
+ call model_aniso_inner_core(r_prem,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL, &
+ vpv,vph,vsv,vsh,rho,eta_aniso)
+
+ 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 > R670/R_EARTH .and. .not. suppress_mantle_extension ) then
+
+ ! extend 3-D mantle model above the Moho to the surface before adding the crust
+ if( r_prem < RMOHO/R_EARTH) then
+ r_used = r_prem
+ else
+ if( CRUSTAL ) then
+ ! fills 3-D mantle model above the Moho with the values at moho depth
+ r_used = RMOHO/R_EARTH
+ endif
+ endif
+ call model_aniso_mantle(r_used,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)
+
+ else
+ ! fills the rest of the mantle with the isotropic model
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.d0
+ c15 = 0.d0
+ c16 = 0.d0
+ c22 = c11
+ c23 = c12
+ c24 = 0.d0
+ c25 = 0.d0
+ c26 = 0.d0
+ c33 = c11
+ c34 = 0.d0
+ c35 = 0.d0
+ c36 = 0.d0
+ c44 = rho*vsv*vsv
+ c45 = 0.d0
+ c46 = 0.d0
+ c55 = c44
+ c56 = 0.d0
+ c66 = c44
+ endif
+ endif ! ANISOTROPIC_3D_MANTLE
+
+!> Hejun
+! Assign Attenuation after get 3-D crustal model
+! This is here to identify how and where to include 3D attenuation
+! if(ATTENUATION .and. ATTENUATION_3D) then
+! call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+! call reduce(theta,phi)
+! theta_degrees = theta / DEGREES_TO_RADIANS
+! phi_degrees = phi / DEGREES_TO_RADIANS
+! tau_e(:) = 0.0d0
+! ! Get the value of Qmu (Attenuation) dependedent on
+! ! the radius (r_prem) and idoubling flag
+! !call model_attenuation_1D_PREM(r_prem, Qmu, idoubling)
+! call model_atten3D_QRFSI12(r_prem*R_EARTH_KM,theta_degrees,phi_degrees,Qmu,QRFSI12_Q,idoubling)
+! ! Get tau_e from tau_s and Qmu
+! call model_attenuation_getstored_tau(Qmu, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
+! endif
+
+ end subroutine meshfem3D_models_get3Dmntl_val
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine meshfem3D_models_get3Dcrust_val(iregion_code,xmesh,ymesh,zmesh,r, &
+ vpv,vph,vsv,vsh,rho,eta_aniso,dvp, &
+ c11,c12,c13,c14,c15,c16,c22,c23,c24,c25, &
+ c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66, &
+ elem_in_crust,moho)
+
+! returns velocities and density for points in 3D crustal region
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer iregion_code
+ ! note: r is the exact radius (and not r_prem with tolerance)
+ double precision xmesh,ymesh,zmesh,r
+ double precision vpv,vph,vsv,vsh,rho,eta_aniso,dvp
+
+ ! 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
+
+ logical elem_in_crust
+ double precision moho
+
+ ! local parameters
+ double precision :: r_dummy,theta,phi
+ double precision :: lat,lon
+ double precision :: vpc,vsc,rhoc !,vpc_eu
+ double precision :: dvs
+ logical :: found_crust !,found_eucrust
+
+ ! checks if anything to do, that is, there is nothing to do
+ ! for point radius smaller than deepest possible crust radius (~80 km depth)
+ if( r < R_DEEPEST_CRUST ) return
+
+ ! gets point's position theta/phi, lat/lon
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ lat = (PI/2.0d0-theta)*180.0d0/PI
+ lon = phi*180.0d0/PI
+ if(lon>180.0d0) lon = lon-360.0d0
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ ! crustal model can vary for different 3-D models
+ select case (THREE_D_MODEL )
+
+ case(THREE_D_MODEL_SEA99_JP3D,THREE_D_MODEL_JP3D)
+ ! tries to use Zhao's model of the crust
+ 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
+ ! makes sure radius is fine
+ if(r > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call model_jp3d_iso_zhao(r,theta,phi,vpc,vsc,dvp,dvs,rhoc,found_crust,JP3DM_V)
+ endif
+ else
+ ! default crust
+ call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
+ endif
+
+ case ( THREE_D_MODEL_PPM )
+ ! takes vs,rho from default crust
+ call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
+
+ ! takes vp from eucrust07
+ !call model_eucrust(lat,lon,r,vpc_eu,found_eucrust,EUCM_V)
+ !if( found_eucrust) then
+ ! vpc=vpc_eu
+ !endif
+
+ case default
+ ! default crust
+ call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
+
+ end select
+
+ ! sets crustal values
+ if( found_crust ) then
+ vpv=vpc
+ vph=vpc
+ vsv=vsc
+ vsh=vsc
+ rho=rhoc
+ eta_aniso=1.0d0
+
+ ! sets anisotropy in crustal region as well
+ 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
+
+ end subroutine meshfem3D_models_get3Dcrust_val
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
+
+! returns velocity/density for default crust
+
+ use meshfem3D_models_par
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ !integer myrank
+ double precision,intent(in) :: lat,lon,r
+ double precision,intent(out) :: vpc,vsc,rhoc
+ double precision,intent(out) :: moho
+ logical,intent(out) :: found_crust
+ logical,intent(in) :: elem_in_crust
+
+ ! initializes
+ vpc = 0.d0
+ vsc = 0.d0
+ rhoc = 0.d0
+ moho = 0.d0
+ found_crust = .false.
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ select case (ITYPE_CRUSTAL_MODEL )
+
+ case (ICRUST_CRUST2)
+ ! crust 2.0
+ call model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V,elem_in_crust)
+
+ case (ICRUST_CRUSTMAPS)
+ ! general crustmaps
+ call model_crustmaps(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,GC_V,elem_in_crust)
+
+ case default
+ stop 'crustal model type not defined'
+
+ end select
+
+
+ end subroutine meshfem3D_model_crust
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine meshfem3D_models_getatten_val(idoubling,xmesh,ymesh,zmesh,r_prem, &
+ tau_e,tau_s,T_c_source, &
+ moho,Qmu,Qkappa,elem_in_crust)
+
+! sets attenuation values tau_e and Qmu for a given point
+!
+! note: only Qmu attenuation considered, Qkappa attenuation not used so far in solver...
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer idoubling
+
+ double precision xmesh,ymesh,zmesh
+
+ double precision r_prem
+ double precision moho
+
+ ! attenuation values
+ double precision Qkappa,Qmu
+ double precision, dimension(N_SLS) :: tau_s, tau_e
+ double precision T_c_source
+
+ logical elem_in_crust
+
+ ! local parameters
+ double precision r_dummy,theta,phi,theta_degrees,phi_degrees
+ double precision, parameter :: rmoho_prem = 6371.0-24.4
+ double precision r_used
+
+ ! initializes
+ tau_e(:) = 0.0d0
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ ! Get the value of Qmu (Attenuation) dependent on
+ ! the radius (r_prem) and idoubling flag
+ if (ATTENUATION_3D) then
+ ! used for models: s362ani_3DQ, s362iso_3DQ, 3D_attenuation
+
+ ! gets spherical coordinates
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ theta_degrees = theta / DEGREES_TO_RADIANS
+ phi_degrees = phi / DEGREES_TO_RADIANS
+
+ ! in case models incorporate a 3D crust, attenuation values for mantle
+ ! get expanded up to surface, and for the crustal points Qmu for PREM crust is imposed
+ r_used = r_prem*R_EARTH_KM
+ if( CRUSTAL ) then
+ if ( r_prem > (ONE-moho) .or. elem_in_crust) then
+ ! points in actual crust: puts point radius into prem crust
+ r_used = rmoho_prem*1.0001
+ else if( r_prem*R_EARTH_KM >= rmoho_prem ) then
+ ! points below actual crust (e.g. oceanic crust case), but above prem moho:
+ ! puts point slightly below prem moho to expand mantle values at that depth
+ r_used = rmoho_prem*0.99999
+ endif
+ endif ! CRUSTAL
+
+ ! gets value according to radius/theta/phi location and idoubling flag
+ call model_atten3D_QRFSI12(r_used,theta_degrees,phi_degrees,Qmu,QRFSI12_Q,idoubling)
+
+ else
+
+ select case (REFERENCE_1D_MODEL)
+
+ ! case(REFERENCE_MODEL_PREM)
+ ! this case is probably not needed since Qmu is 600. between R80 and surface
+ ! call model_attenuation_1D_PREM(r_prem, Qmu)
+
+ case(REFERENCE_MODEL_1DREF)
+ ! 1D Ref changes Qmu at moho depth of 24.4km
+ ! we take the crustal value and assign it to points only inside actual crust,
+ ! otherwise the mantle values is taken
+ ! makes sense especially for points below thin oceanic and thick continental crust
+ if ( CRUSTAL ) then
+ ! takes crustal Q value only if point is in actual crust
+ if ( r_prem > (ONE-moho) .or. elem_in_crust) then
+ ! reference from 1D-REF aka STW105
+ Qmu=300.0d0
+ Qkappa=57822.5d0 ! not used so far...
+ endif
+ endif ! CRUSTAL
+
+ case(REFERENCE_MODEL_SEA1D)
+ ! SEA1D changes Qmu at 25km (moho) depth. we take the crustal value
+ ! for points only inside actual crust
+ if ( CRUSTAL ) then
+ ! takes crustal Q value only if point is in actual crust
+ if ( r_prem > (ONE-moho) .or. elem_in_crust) then
+ ! reference from Sea1D
+ Qmu = 300.0d0
+ Qkappa = 57822.5d0 ! not used so far...
+ endif
+ endif
+
+ end select
+
+ end if
+
+ ! Get tau_e from tau_s and Qmu
+ call model_attenuation_getstored_tau(Qmu, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
+
+ end subroutine meshfem3D_models_getatten_val
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine meshfem3D_models_impose_val(vpv,vph,vsv,vsh,rho,dvp,eta_aniso,&
+ myrank,iregion_code,ispec,i,j,k)
+
+! overwrites values with updated model values (from iteration step) here, given at all GLL points
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ double precision :: vpv,vph,vsv,vsh,rho,dvp,eta_aniso
+ integer :: myrank,iregion_code,ispec,i,j,k
+
+ ! local parameters
+ double precision :: vp,vs
+
+ ! model GLL
+ if( MGLL_V%MODEL_GLL .and. iregion_code == IREGION_CRUST_MANTLE ) then
+
+ ! isotropic model
+ if( .not. TRANSVERSE_ISOTROPY ) then
+
+ !check
+ if( ispec > size(MGLL_V%vp_new(1,1,1,:)) ) then
+ call exit_MPI(myrank,'model gll: ispec too big')
+ endif
+
+ ! takes stored gll values from file
+ ! ( note that these values are non-dimensionalized)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ vp = dble( MGLL_V%vp_new(i,j,k,ispec) )
+ vs = dble( MGLL_V%vs_new(i,j,k,ispec) )
+ rho = dble( MGLL_V%rho_new(i,j,k,ispec) )
+ else
+ vp = MGLL_V%vp_new(i,j,k,ispec)
+ vs = MGLL_V%vs_new(i,j,k,ispec)
+ rho = MGLL_V%rho_new(i,j,k,ispec)
+ endif
+ ! isotropic model
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ rho = rho
+ eta_aniso = 1.0d0
+
+ ! transverse isotropic model
+ else
+
+ !check
+ if( ispec > size(MGLL_V%vpv_new(1,1,1,:)) ) then
+ call exit_MPI(myrank,'model gll: ispec too big')
+ endif
+
+ ! takes stored gll values from file
+ if(CUSTOM_REAL == SIZE_REAL) then
+ vph = dble( MGLL_V%vph_new(i,j,k,ispec) )
+ vpv = dble( MGLL_V%vpv_new(i,j,k,ispec) )
+ vsh = dble( MGLL_V%vsh_new(i,j,k,ispec) )
+ vsv = dble( MGLL_V%vsv_new(i,j,k,ispec) )
+ rho = dble( MGLL_V%rho_new(i,j,k,ispec) )
+ eta_aniso = dble( MGLL_V%eta_new(i,j,k,ispec) )
+ else
+ vph = MGLL_V%vph_new(i,j,k,ispec)
+ vpv = MGLL_V%vpv_new(i,j,k,ispec)
+ vsh = MGLL_V%vsh_new(i,j,k,ispec)
+ vsv = MGLL_V%vsv_new(i,j,k,ispec)
+ rho = MGLL_V%rho_new(i,j,k,ispec)
+ eta_aniso = MGLL_V%eta_new(i,j,k,ispec)
+ endif
+ endif
+ ! no mantle vp perturbation
+ dvp = 0.0d0
+
+ endif ! MODEL_GLL
+
+ end subroutine meshfem3D_models_impose_val
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_1066a.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_1066a.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_1066a.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_1066a.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1173 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! 1066A
+!
+! Spherically symmetric earth model 1066A [Gilbert and Dziewonski, 1975].
+!
+! When ATTENTUATION is on, it uses an unpublished 1D attenuation model from Scripps.
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_1066a_broadcast(CRUSTAL,M1066a_V)
+
+! standard routine to setup model
+
+ 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 :: CRUSTAL
+
+ ! all processes will define same parameters
+ call define_model_1066a(CRUSTAL, M1066a_V)
+
+ end subroutine model_1066a_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ 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 (SUPPRESS_CRUSTAL_MESH .or. 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/src/model_1dref.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_1dref.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_1dref.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_1dref.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,7442 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+!
+! 1D REF model of Kustowski et al. (2008)
+!
+! this is STW105 - new reference model, also known as REF
+!
+! A recent 1D Earth model developed by Kustowski et al. This model is the 1D background
+! model for the 3D models s362ani, s362wmani, s362ani_prem, and s29ea.
+!
+! see chapter 3, in:
+! Kustowski, B, Ekstrom, G., and A. M. Dziewonski, 2008,
+! Anisotropic shear-wave velocity structure of the Earth's mantle: A global model,
+! J. Geophys. Res., 113, B06306, doi:10.1029/2007JB005169.
+!
+! model is identical to PREM at crustal depths, between 220 and 400km
+! and below 670km.
+!
+! attenuation structure is taken from model QL6:
+! Durek, J. J. and G. Ekström, 1996.
+! A radial model of anelasticity consistent with long period surface wave attenuation,
+! Bull. Seism. Soc. Am., 86, 144-158
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_1dref_broadcast(CRUSTAL,Mref_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+
+ ! model_1dref_variables
+ type model_1dref_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_1dref_variables
+
+ type (model_1dref_variables) Mref_V
+ ! model_1dref_variables
+
+ logical :: CRUSTAL
+
+ ! all processes will define same parameters
+ call define_model_1dref(CRUSTAL,Mref_V)
+
+ end subroutine model_1dref_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_1dref(x,rho,vpv,vph,vsv,vsh,eta,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
+
+ implicit none
+
+ include "constants.h"
+
+! model_1dref_variables
+ type model_1dref_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_1dref_variables
+
+ type (model_1dref_variables) Mref_V
+! model_1dref_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 model is used, mantle gets expanded up to surface
+ ! for any depth less than 24.4 km, values from mantle below moho are taken
+ if(CRUSTAL .and. i > 717) i = 717
+
+
+ if(i == 1) then
+ ! first layer in inner core
+ 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
+ ! interpolates between one layer below to actual radius layer,
+ ! that is 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))
+ ! interpolated model parameters
+ 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_1dref
+
+!-------------------
+
+ subroutine define_model_1dref(USE_EXTERNAL_CRUSTAL_MODEL,Mref_V)
+
+ implicit none
+ include "constants.h"
+
+! model_1dref_variables
+ type model_1dref_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_1dref_variables
+
+ type (model_1dref_variables) Mref_V
+! model_1dref_variables
+
+ logical USE_EXTERNAL_CRUSTAL_MODEL
+
+
+! 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 /)
+
+! strip the crust and replace it by mantle
+ if (SUPPRESS_CRUSTAL_MESH .or. USE_EXTERNAL_CRUSTAL_MODEL) then
+ ! sets values for depths less than 24.4 km to mantle values below
+ 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)
+ Mref_V%Qmu_ref(718:750) = Mref_V%Qmu_ref(717)
+ Mref_V%Qkappa_ref(718:750) = Mref_V%Qkappa_ref(717)
+ endif
+
+
+ end subroutine define_model_1dref
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_ak135.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_ak135.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_ak135.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_ak135.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1021 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! AK135
+!
+! Spherically symmetric isotropic AK135 model [Kennett et al., 1995].
+!
+! B. L. N. Kennett, E. R. Engdahl and R. Buland,
+! Constraints on seismic velocities in the Earth from traveltimes,
+! Geophysical Journal International, Volume 122, Issue 1, Pages 1-351 (1995),
+! DOI: 10.1111/j.1365-246X.1995.tb03540.x
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_ak135_broadcast(CRUSTAL,Mak135_V)
+
+! standard routine to setup model
+
+ 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 :: CRUSTAL
+
+ ! all processes will define same parameters
+ call define_model_ak135(CRUSTAL, Mak135_V)
+
+ end subroutine model_ak135_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ 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
+
+! 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 > 24) i = 24
+
+ if(iregion_code == IREGION_OUTER_CORE .and. i < 26) i = 26
+ if(iregion_code == IREGION_OUTER_CORE .and. i > 69) i = 69
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. i < 71) i = 71
+
+ 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
+
+! define all the values in the model
+
+ Mak135_V%radius_ak135( 1) = 0.000000000000000E+000
+ 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) = 659260.000000000
+ Mak135_V%radius_ak135( 14) = 710000.000000000
+ Mak135_V%radius_ak135( 15) = 760690.000000000
+ Mak135_V%radius_ak135( 16) = 811400.000000000
+ Mak135_V%radius_ak135( 17) = 862110.000000000
+ Mak135_V%radius_ak135( 18) = 912830.000000000
+ Mak135_V%radius_ak135( 19) = 963540.000000000
+ Mak135_V%radius_ak135( 20) = 1014250.00000000
+ Mak135_V%radius_ak135( 21) = 1064960.00000000
+ Mak135_V%radius_ak135( 22) = 1115680.00000000
+ Mak135_V%radius_ak135( 23) = 1166390.00000000
+ Mak135_V%radius_ak135( 24) = 1217500.00000000
+ Mak135_V%radius_ak135( 25) = 1217500.00000000
+ Mak135_V%radius_ak135( 26) = 1267430.00000000
+ Mak135_V%radius_ak135( 27) = 1317760.00000000
+ Mak135_V%radius_ak135( 28) = 1368090.00000000
+ Mak135_V%radius_ak135( 29) = 1418420.00000000
+ Mak135_V%radius_ak135( 30) = 1468760.00000000
+ Mak135_V%radius_ak135( 31) = 1519090.00000000
+ Mak135_V%radius_ak135( 32) = 1569420.00000000
+ Mak135_V%radius_ak135( 33) = 1670080.00000000
+ Mak135_V%radius_ak135( 34) = 1720410.00000000
+ Mak135_V%radius_ak135( 35) = 1770740.00000000
+ Mak135_V%radius_ak135( 36) = 1821070.00000000
+ Mak135_V%radius_ak135( 37) = 1871400.00000000
+ Mak135_V%radius_ak135( 38) = 1921740.00000000
+ Mak135_V%radius_ak135( 39) = 1972070.00000000
+ Mak135_V%radius_ak135( 40) = 2022400.00000000
+ Mak135_V%radius_ak135( 41) = 2072730.00000000
+ Mak135_V%radius_ak135( 42) = 2123060.00000000
+ Mak135_V%radius_ak135( 43) = 2173390.00000000
+ Mak135_V%radius_ak135( 44) = 2223720.00000000
+ Mak135_V%radius_ak135( 45) = 2274050.00000000
+ Mak135_V%radius_ak135( 46) = 2324380.00000000
+ Mak135_V%radius_ak135( 47) = 2374720.00000000
+ Mak135_V%radius_ak135( 48) = 2425050.00000000
+ Mak135_V%radius_ak135( 49) = 2475380.00000000
+ Mak135_V%radius_ak135( 50) = 2525710.00000000
+ Mak135_V%radius_ak135( 51) = 2576040.00000000
+ Mak135_V%radius_ak135( 52) = 2626370.00000000
+ Mak135_V%radius_ak135( 53) = 2676700.00000000
+ Mak135_V%radius_ak135( 54) = 2727030.00000000
+ Mak135_V%radius_ak135( 55) = 2777360.00000000
+ Mak135_V%radius_ak135( 56) = 2827700.00000000
+ Mak135_V%radius_ak135( 57) = 2878030.00000000
+ Mak135_V%radius_ak135( 58) = 2928360.00000000
+ Mak135_V%radius_ak135( 59) = 2978690.00000000
+ Mak135_V%radius_ak135( 60) = 3029020.00000000
+ Mak135_V%radius_ak135( 61) = 3079350.00000000
+ Mak135_V%radius_ak135( 62) = 3129680.00000000
+ Mak135_V%radius_ak135( 63) = 3180010.00000000
+ Mak135_V%radius_ak135( 64) = 3230340.00000000
+ Mak135_V%radius_ak135( 65) = 3280680.00000000
+ Mak135_V%radius_ak135( 66) = 3331010.00000000
+ Mak135_V%radius_ak135( 67) = 3381340.00000000
+ Mak135_V%radius_ak135( 68) = 3431670.00000000
+ Mak135_V%radius_ak135( 69) = 3479500.00000000
+ Mak135_V%radius_ak135( 70) = 3479500.00000000
+ Mak135_V%radius_ak135( 71) = 3531670.00000000
+ Mak135_V%radius_ak135( 72) = 3581330.00000000
+ Mak135_V%radius_ak135( 73) = 3631000.00000000
+ Mak135_V%radius_ak135( 74) = 3631000.00000000
+ Mak135_V%radius_ak135( 75) = 3681000.00000000
+ Mak135_V%radius_ak135( 76) = 3731000.00000000
+ Mak135_V%radius_ak135( 77) = 3779500.00000000
+ Mak135_V%radius_ak135( 78) = 3829000.00000000
+ Mak135_V%radius_ak135( 79) = 3878500.00000000
+ Mak135_V%radius_ak135( 80) = 3928000.00000000
+ Mak135_V%radius_ak135( 81) = 3977500.00000000
+ Mak135_V%radius_ak135( 82) = 4027000.00000000
+ Mak135_V%radius_ak135( 83) = 4076500.00000000
+ Mak135_V%radius_ak135( 84) = 4126000.00000000
+ Mak135_V%radius_ak135( 85) = 4175500.00000000
+ Mak135_V%radius_ak135( 86) = 4225000.00000000
+ Mak135_V%radius_ak135( 87) = 4274500.00000000
+ Mak135_V%radius_ak135( 88) = 4324000.00000000
+ Mak135_V%radius_ak135( 89) = 4373500.00000000
+ Mak135_V%radius_ak135( 90) = 4423000.00000000
+ Mak135_V%radius_ak135( 91) = 4472500.00000000
+ Mak135_V%radius_ak135( 92) = 4522000.00000000
+ Mak135_V%radius_ak135( 93) = 4571500.00000000
+ Mak135_V%radius_ak135( 94) = 4621000.00000000
+ Mak135_V%radius_ak135( 95) = 4670500.00000000
+ Mak135_V%radius_ak135( 96) = 4720000.00000000
+ Mak135_V%radius_ak135( 97) = 4769500.00000000
+ Mak135_V%radius_ak135( 98) = 4819000.00000000
+ Mak135_V%radius_ak135( 99) = 4868500.00000000
+ Mak135_V%radius_ak135(100) = 4918000.00000000
+ Mak135_V%radius_ak135(101) = 4967500.00000000
+ Mak135_V%radius_ak135(102) = 5017000.00000000
+ Mak135_V%radius_ak135(103) = 5066500.00000000
+ Mak135_V%radius_ak135(104) = 5116000.00000000
+ Mak135_V%radius_ak135(105) = 5165500.00000000
+ Mak135_V%radius_ak135(106) = 5215000.00000000
+ Mak135_V%radius_ak135(107) = 5264500.00000000
+ Mak135_V%radius_ak135(108) = 5314000.00000000
+ Mak135_V%radius_ak135(109) = 5363500.00000000
+ Mak135_V%radius_ak135(110) = 5413000.00000000
+ Mak135_V%radius_ak135(111) = 5462500.00000000
+ Mak135_V%radius_ak135(112) = 5512000.00000000
+ Mak135_V%radius_ak135(113) = 5561500.00000000
+ Mak135_V%radius_ak135(114) = 5611000.00000000
+ Mak135_V%radius_ak135(115) = 5661000.00000000
+ Mak135_V%radius_ak135(116) = 5711000.00000000
+ Mak135_V%radius_ak135(117) = 5711000.00000000
+ Mak135_V%radius_ak135(118) = 5761000.00000000
+ Mak135_V%radius_ak135(119) = 5811000.00000000
+ Mak135_V%radius_ak135(120) = 5861000.00000000
+ Mak135_V%radius_ak135(121) = 5911000.00000000
+ Mak135_V%radius_ak135(122) = 5961000.00000000
+ Mak135_V%radius_ak135(123) = 5961000.00000000
+ Mak135_V%radius_ak135(124) = 6011000.00000000
+ Mak135_V%radius_ak135(125) = 6061000.00000000
+ Mak135_V%radius_ak135(126) = 6111000.00000000
+ Mak135_V%radius_ak135(127) = 6161000.00000000
+ Mak135_V%radius_ak135(128) = 6161000.00000000
+ Mak135_V%radius_ak135(129) = 6206000.00000000
+ Mak135_V%radius_ak135(130) = 6251000.00000000
+ Mak135_V%radius_ak135(131) = 6293500.00000000
+ Mak135_V%radius_ak135(132) = 6336000.00000000
+ Mak135_V%radius_ak135(133) = 6336000.00000000
+ Mak135_V%radius_ak135(134) = 6351000.00000000
+ Mak135_V%radius_ak135(135) = 6351000.00000000
+ Mak135_V%radius_ak135(136) = 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.9217000000000
+ Mak135_V%density_ak135( 14) = 12.9070000000000
+ Mak135_V%density_ak135( 15) = 12.8917000000000
+ Mak135_V%density_ak135( 16) = 12.8751000000000
+ Mak135_V%density_ak135( 17) = 12.8574000000000
+ Mak135_V%density_ak135( 18) = 12.8387000000000
+ Mak135_V%density_ak135( 19) = 12.8188000000000
+ Mak135_V%density_ak135( 20) = 12.7980000000000
+ Mak135_V%density_ak135( 21) = 12.7760000000000
+ Mak135_V%density_ak135( 22) = 12.7530000000000
+ Mak135_V%density_ak135( 23) = 12.7289000000000
+ Mak135_V%density_ak135( 24) = 12.7037000000000
+ Mak135_V%density_ak135( 25) = 12.1391000000000
+ Mak135_V%density_ak135( 26) = 12.1133000000000
+ Mak135_V%density_ak135( 27) = 12.0867000000000
+ Mak135_V%density_ak135( 28) = 12.0593000000000
+ Mak135_V%density_ak135( 29) = 12.0311000000000
+ Mak135_V%density_ak135( 30) = 12.0001000000000
+ Mak135_V%density_ak135( 31) = 11.9722000000000
+ Mak135_V%density_ak135( 32) = 11.9414000000000
+ Mak135_V%density_ak135( 33) = 11.8772000000000
+ Mak135_V%density_ak135( 34) = 11.8437000000000
+ Mak135_V%density_ak135( 35) = 11.8092000000000
+ Mak135_V%density_ak135( 36) = 11.7737000000000
+ Mak135_V%density_ak135( 37) = 11.7373000000000
+ Mak135_V%density_ak135( 38) = 11.6998000000000
+ Mak135_V%density_ak135( 39) = 11.6612000000000
+ Mak135_V%density_ak135( 40) = 11.6216000000000
+ Mak135_V%density_ak135( 41) = 11.5809000000000
+ Mak135_V%density_ak135( 42) = 11.5391000000000
+ Mak135_V%density_ak135( 43) = 11.4962000000000
+ Mak135_V%density_ak135( 44) = 11.4521000000000
+ Mak135_V%density_ak135( 45) = 11.4069000000000
+ Mak135_V%density_ak135( 46) = 11.3604000000000
+ Mak135_V%density_ak135( 47) = 11.3127000000000
+ Mak135_V%density_ak135( 48) = 11.2639000000000
+ Mak135_V%density_ak135( 49) = 11.2137000000000
+ Mak135_V%density_ak135( 50) = 11.1623000000000
+ Mak135_V%density_ak135( 51) = 11.1095000000000
+ Mak135_V%density_ak135( 52) = 11.0555000000000
+ Mak135_V%density_ak135( 53) = 11.0001000000000
+ Mak135_V%density_ak135( 54) = 10.9434000000000
+ Mak135_V%density_ak135( 55) = 10.8852000000000
+ Mak135_V%density_ak135( 56) = 10.8257000000000
+ Mak135_V%density_ak135( 57) = 10.7647000000000
+ Mak135_V%density_ak135( 58) = 10.7023000000000
+ Mak135_V%density_ak135( 59) = 10.6385000000000
+ Mak135_V%density_ak135( 60) = 10.5731000000000
+ Mak135_V%density_ak135( 61) = 10.5062000000000
+ Mak135_V%density_ak135( 62) = 10.4378000000000
+ Mak135_V%density_ak135( 63) = 10.3679000000000
+ Mak135_V%density_ak135( 64) = 10.2964000000000
+ Mak135_V%density_ak135( 65) = 10.2233000000000
+ Mak135_V%density_ak135( 66) = 10.1485000000000
+ Mak135_V%density_ak135( 67) = 10.0722000000000
+ Mak135_V%density_ak135( 68) = 9.99420000000000
+ Mak135_V%density_ak135( 69) = 9.91450000000000
+ Mak135_V%density_ak135( 70) = 5.77210000000000
+ Mak135_V%density_ak135( 71) = 5.74580000000000
+ Mak135_V%density_ak135( 72) = 5.71960000000000
+ Mak135_V%density_ak135( 73) = 5.69340000000000
+ Mak135_V%density_ak135( 74) = 5.43870000000000
+ Mak135_V%density_ak135( 75) = 5.41760000000000
+ Mak135_V%density_ak135( 76) = 5.39620000000000
+ Mak135_V%density_ak135( 77) = 5.37480000000000
+ Mak135_V%density_ak135( 78) = 5.35310000000000
+ Mak135_V%density_ak135( 79) = 5.33130000000000
+ Mak135_V%density_ak135( 80) = 5.30920000000000
+ Mak135_V%density_ak135( 81) = 5.28700000000000
+ Mak135_V%density_ak135( 82) = 5.26460000000000
+ Mak135_V%density_ak135( 83) = 5.24200000000000
+ Mak135_V%density_ak135( 84) = 5.21920000000000
+ Mak135_V%density_ak135( 85) = 5.19630000000000
+ Mak135_V%density_ak135( 86) = 5.17320000000000
+ Mak135_V%density_ak135( 87) = 5.14990000000000
+ Mak135_V%density_ak135( 88) = 5.12640000000000
+ Mak135_V%density_ak135( 89) = 5.10270000000000
+ Mak135_V%density_ak135( 90) = 5.07890000000000
+ Mak135_V%density_ak135( 91) = 5.05480000000000
+ Mak135_V%density_ak135( 92) = 5.03060000000000
+ Mak135_V%density_ak135( 93) = 5.00620000000000
+ Mak135_V%density_ak135( 94) = 4.98170000000000
+ Mak135_V%density_ak135( 95) = 4.95700000000000
+ Mak135_V%density_ak135( 96) = 4.93210000000000
+ Mak135_V%density_ak135( 97) = 4.90690000000000
+ Mak135_V%density_ak135( 98) = 4.88170000000000
+ Mak135_V%density_ak135( 99) = 4.85620000000000
+ Mak135_V%density_ak135(100) = 4.83070000000000
+ Mak135_V%density_ak135(101) = 4.80500000000000
+ Mak135_V%density_ak135(102) = 4.77900000000000
+ Mak135_V%density_ak135(103) = 4.75280000000000
+ Mak135_V%density_ak135(104) = 4.72660000000000
+ Mak135_V%density_ak135(105) = 4.70010000000000
+ Mak135_V%density_ak135(106) = 4.67350000000000
+ Mak135_V%density_ak135(107) = 4.64670000000000
+ Mak135_V%density_ak135(108) = 4.61980000000000
+ Mak135_V%density_ak135(109) = 4.59260000000000
+ Mak135_V%density_ak135(110) = 4.56540000000000
+ Mak135_V%density_ak135(111) = 4.51620000000000
+ Mak135_V%density_ak135(112) = 4.46500000000000
+ Mak135_V%density_ak135(113) = 4.41180000000000
+ Mak135_V%density_ak135(114) = 4.35650000000000
+ Mak135_V%density_ak135(115) = 4.29860000000000
+ Mak135_V%density_ak135(116) = 4.23870000000000
+ Mak135_V%density_ak135(117) = 3.92010000000000
+ Mak135_V%density_ak135(118) = 3.92060000000000
+ Mak135_V%density_ak135(119) = 3.92180000000000
+ Mak135_V%density_ak135(120) = 3.92330000000000
+ Mak135_V%density_ak135(121) = 3.92730000000000
+ Mak135_V%density_ak135(122) = 3.93170000000000
+ Mak135_V%density_ak135(123) = 3.50680000000000
+ Mak135_V%density_ak135(124) = 3.45770000000000
+ Mak135_V%density_ak135(125) = 3.41100000000000
+ Mak135_V%density_ak135(126) = 3.36630000000000
+ Mak135_V%density_ak135(127) = 3.32430000000000
+ Mak135_V%density_ak135(128) = 3.32430000000000
+ Mak135_V%density_ak135(129) = 3.37110000000000
+ Mak135_V%density_ak135(130) = 3.42680000000000
+ Mak135_V%density_ak135(131) = 3.34500000000000
+ Mak135_V%density_ak135(132) = 3.32000000000000
+ Mak135_V%density_ak135(133) = 2.92000000000000
+ Mak135_V%density_ak135(134) = 2.92000000000000
+ Mak135_V%density_ak135(135) = 2.72000000000000
+ Mak135_V%density_ak135(136) = 2.72000000000000
+
+ 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.1941000000000
+ Mak135_V%vp_ak135( 14) = 11.1830000000000
+ Mak135_V%vp_ak135( 15) = 11.1715000000000
+ Mak135_V%vp_ak135( 16) = 11.1590000000000
+ Mak135_V%vp_ak135( 17) = 11.1457000000000
+ Mak135_V%vp_ak135( 18) = 11.1316000000000
+ Mak135_V%vp_ak135( 19) = 11.1166000000000
+ Mak135_V%vp_ak135( 20) = 11.0983000000000
+ Mak135_V%vp_ak135( 21) = 11.0850000000000
+ Mak135_V%vp_ak135( 22) = 11.0718000000000
+ Mak135_V%vp_ak135( 23) = 11.0585000000000
+ Mak135_V%vp_ak135( 24) = 11.0427000000000
+ Mak135_V%vp_ak135( 25) = 10.2890000000000
+ Mak135_V%vp_ak135( 26) = 10.2854000000000
+ Mak135_V%vp_ak135( 27) = 10.2745000000000
+ Mak135_V%vp_ak135( 28) = 10.2565000000000
+ Mak135_V%vp_ak135( 29) = 10.2329000000000
+ Mak135_V%vp_ak135( 30) = 10.2049000000000
+ Mak135_V%vp_ak135( 31) = 10.1739000000000
+ Mak135_V%vp_ak135( 32) = 10.1415000000000
+ Mak135_V%vp_ak135( 33) = 10.0768000000000
+ Mak135_V%vp_ak135( 34) = 10.0439000000000
+ Mak135_V%vp_ak135( 35) = 10.0103000000000
+ Mak135_V%vp_ak135( 36) = 9.97610000000000
+ Mak135_V%vp_ak135( 37) = 9.94100000000000
+ Mak135_V%vp_ak135( 38) = 9.90510000000000
+ Mak135_V%vp_ak135( 39) = 9.86820000000000
+ Mak135_V%vp_ak135( 40) = 9.83040000000000
+ Mak135_V%vp_ak135( 41) = 9.79140000000000
+ Mak135_V%vp_ak135( 42) = 9.75130000000000
+ Mak135_V%vp_ak135( 43) = 9.71000000000000
+ Mak135_V%vp_ak135( 44) = 9.66730000000000
+ Mak135_V%vp_ak135( 45) = 9.62320000000000
+ Mak135_V%vp_ak135( 46) = 9.57770000000000
+ Mak135_V%vp_ak135( 47) = 9.53060000000000
+ Mak135_V%vp_ak135( 48) = 9.48140000000000
+ Mak135_V%vp_ak135( 49) = 9.42970000000000
+ Mak135_V%vp_ak135( 50) = 9.37600000000000
+ Mak135_V%vp_ak135( 51) = 9.32050000000000
+ Mak135_V%vp_ak135( 52) = 9.26340000000000
+ Mak135_V%vp_ak135( 53) = 9.20420000000000
+ Mak135_V%vp_ak135( 54) = 9.14260000000000
+ Mak135_V%vp_ak135( 55) = 9.07920000000000
+ Mak135_V%vp_ak135( 56) = 9.01380000000000
+ Mak135_V%vp_ak135( 57) = 8.94610000000000
+ Mak135_V%vp_ak135( 58) = 8.87610000000000
+ Mak135_V%vp_ak135( 59) = 8.80360000000000
+ Mak135_V%vp_ak135( 60) = 8.72830000000000
+ Mak135_V%vp_ak135( 61) = 8.64960000000000
+ Mak135_V%vp_ak135( 62) = 8.56920000000000
+ Mak135_V%vp_ak135( 63) = 8.48610000000000
+ Mak135_V%vp_ak135( 64) = 8.40010000000000
+ Mak135_V%vp_ak135( 65) = 8.31220000000000
+ Mak135_V%vp_ak135( 66) = 8.22130000000000
+ Mak135_V%vp_ak135( 67) = 8.12830000000000
+ Mak135_V%vp_ak135( 68) = 8.03820000000000
+ Mak135_V%vp_ak135( 69) = 8.00000000000000
+ Mak135_V%vp_ak135( 70) = 13.6601000000000
+ Mak135_V%vp_ak135( 71) = 13.6570000000000
+ Mak135_V%vp_ak135( 72) = 13.6533000000000
+ Mak135_V%vp_ak135( 73) = 13.6498000000000
+ Mak135_V%vp_ak135( 74) = 13.6498000000000
+ Mak135_V%vp_ak135( 75) = 13.5899000000000
+ Mak135_V%vp_ak135( 76) = 13.5311000000000
+ Mak135_V%vp_ak135( 77) = 13.4741000000000
+ Mak135_V%vp_ak135( 78) = 13.4156000000000
+ Mak135_V%vp_ak135( 79) = 13.3584000000000
+ Mak135_V%vp_ak135( 80) = 13.3017000000000
+ Mak135_V%vp_ak135( 81) = 13.2465000000000
+ Mak135_V%vp_ak135( 82) = 13.1895000000000
+ Mak135_V%vp_ak135( 83) = 13.1337000000000
+ Mak135_V%vp_ak135( 84) = 13.0786000000000
+ Mak135_V%vp_ak135( 85) = 13.0226000000000
+ Mak135_V%vp_ak135( 86) = 12.9663000000000
+ Mak135_V%vp_ak135( 87) = 12.9093000000000
+ Mak135_V%vp_ak135( 88) = 12.8524000000000
+ Mak135_V%vp_ak135( 89) = 12.7956000000000
+ Mak135_V%vp_ak135( 90) = 12.7384000000000
+ Mak135_V%vp_ak135( 91) = 12.6807000000000
+ Mak135_V%vp_ak135( 92) = 12.6226000000000
+ Mak135_V%vp_ak135( 93) = 12.5638000000000
+ Mak135_V%vp_ak135( 94) = 12.5030000000000
+ Mak135_V%vp_ak135( 95) = 12.4427000000000
+ Mak135_V%vp_ak135( 96) = 12.3813000000000
+ Mak135_V%vp_ak135( 97) = 12.3181000000000
+ Mak135_V%vp_ak135( 98) = 12.2558000000000
+ Mak135_V%vp_ak135( 99) = 12.1912000000000
+ Mak135_V%vp_ak135(100) = 12.1247000000000
+ Mak135_V%vp_ak135(101) = 12.0571000000000
+ Mak135_V%vp_ak135(102) = 11.9891000000000
+ Mak135_V%vp_ak135(103) = 11.9208000000000
+ Mak135_V%vp_ak135(104) = 11.8491000000000
+ Mak135_V%vp_ak135(105) = 11.7768000000000
+ Mak135_V%vp_ak135(106) = 11.7020000000000
+ Mak135_V%vp_ak135(107) = 11.6265000000000
+ Mak135_V%vp_ak135(108) = 11.5493000000000
+ Mak135_V%vp_ak135(109) = 11.4704000000000
+ Mak135_V%vp_ak135(110) = 11.3897000000000
+ Mak135_V%vp_ak135(111) = 11.3068000000000
+ Mak135_V%vp_ak135(112) = 11.2228000000000
+ Mak135_V%vp_ak135(113) = 11.1355000000000
+ Mak135_V%vp_ak135(114) = 11.0553000000000
+ Mak135_V%vp_ak135(115) = 10.9222000000000
+ Mak135_V%vp_ak135(116) = 10.7909000000000
+ Mak135_V%vp_ak135(117) = 10.2000000000000
+ Mak135_V%vp_ak135(118) = 10.0320000000000
+ Mak135_V%vp_ak135(119) = 9.86400000000000
+ Mak135_V%vp_ak135(120) = 9.69620000000000
+ Mak135_V%vp_ak135(121) = 9.52800000000000
+ Mak135_V%vp_ak135(122) = 9.36010000000000
+ Mak135_V%vp_ak135(123) = 9.03020000000000
+ Mak135_V%vp_ak135(124) = 8.84760000000000
+ Mak135_V%vp_ak135(125) = 8.66500000000000
+ Mak135_V%vp_ak135(126) = 8.48220000000000
+ Mak135_V%vp_ak135(127) = 8.30070000000000
+ Mak135_V%vp_ak135(128) = 8.30070000000000
+ Mak135_V%vp_ak135(129) = 8.17500000000000
+ Mak135_V%vp_ak135(130) = 8.05050000000000
+ Mak135_V%vp_ak135(131) = 8.04500000000000
+ Mak135_V%vp_ak135(132) = 8.04000000000000
+ Mak135_V%vp_ak135(133) = 6.50000000000000
+ Mak135_V%vp_ak135(134) = 6.50000000000000
+ Mak135_V%vp_ak135(135) = 5.80000000000000
+ Mak135_V%vp_ak135(136) = 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.62020000000000
+ Mak135_V%vs_ak135( 14) = 3.61300000000000
+ Mak135_V%vs_ak135( 15) = 3.60440000000000
+ Mak135_V%vs_ak135( 16) = 3.59570000000000
+ Mak135_V%vs_ak135( 17) = 3.58640000000000
+ Mak135_V%vs_ak135( 18) = 3.57650000000000
+ Mak135_V%vs_ak135( 19) = 3.56610000000000
+ Mak135_V%vs_ak135( 20) = 3.55510000000000
+ Mak135_V%vs_ak135( 21) = 3.54350000000000
+ Mak135_V%vs_ak135( 22) = 3.53140000000000
+ Mak135_V%vs_ak135( 23) = 3.51870000000000
+ Mak135_V%vs_ak135( 24) = 3.50430000000000
+ Mak135_V%vs_ak135( 25) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 26) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 27) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 28) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 29) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 30) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 31) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 32) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 33) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 34) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 35) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 36) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 37) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 38) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 39) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 40) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 41) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 42) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 43) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 44) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 45) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 46) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 47) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 48) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 49) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 50) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 51) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 52) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 53) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 54) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 55) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 56) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 57) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 58) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 59) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 60) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 61) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 62) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 63) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 64) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 65) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 66) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 67) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 68) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 69) = 0.000000000000000E+000
+ Mak135_V%vs_ak135( 70) = 7.28170000000000
+ Mak135_V%vs_ak135( 71) = 7.27000000000000
+ Mak135_V%vs_ak135( 72) = 7.25930000000000
+ Mak135_V%vs_ak135( 73) = 7.24850000000000
+ Mak135_V%vs_ak135( 74) = 7.24850000000000
+ Mak135_V%vs_ak135( 75) = 7.22530000000000
+ Mak135_V%vs_ak135( 76) = 7.20310000000000
+ Mak135_V%vs_ak135( 77) = 7.18040000000000
+ Mak135_V%vs_ak135( 78) = 7.15840000000000
+ Mak135_V%vs_ak135( 79) = 7.13680000000000
+ Mak135_V%vs_ak135( 80) = 7.11440000000000
+ Mak135_V%vs_ak135( 81) = 7.09320000000000
+ Mak135_V%vs_ak135( 82) = 7.07220000000000
+ Mak135_V%vs_ak135( 83) = 7.05040000000000
+ Mak135_V%vs_ak135( 84) = 7.02860000000000
+ Mak135_V%vs_ak135( 85) = 7.00690000000000
+ Mak135_V%vs_ak135( 86) = 6.98520000000000
+ Mak135_V%vs_ak135( 87) = 6.96250000000000
+ Mak135_V%vs_ak135( 88) = 6.94160000000000
+ Mak135_V%vs_ak135( 89) = 6.91940000000000
+ Mak135_V%vs_ak135( 90) = 6.89720000000000
+ Mak135_V%vs_ak135( 91) = 6.87430000000000
+ Mak135_V%vs_ak135( 92) = 6.85170000000000
+ Mak135_V%vs_ak135( 93) = 6.82890000000000
+ Mak135_V%vs_ak135( 94) = 6.80560000000000
+ Mak135_V%vs_ak135( 95) = 6.78200000000000
+ Mak135_V%vs_ak135( 96) = 6.75790000000000
+ Mak135_V%vs_ak135( 97) = 6.73230000000000
+ Mak135_V%vs_ak135( 98) = 6.70700000000000
+ Mak135_V%vs_ak135( 99) = 6.68130000000000
+ Mak135_V%vs_ak135(100) = 6.65540000000000
+ Mak135_V%vs_ak135(101) = 6.62850000000000
+ Mak135_V%vs_ak135(102) = 6.60090000000000
+ Mak135_V%vs_ak135(103) = 6.57280000000000
+ Mak135_V%vs_ak135(104) = 6.54310000000000
+ Mak135_V%vs_ak135(105) = 6.51310000000000
+ Mak135_V%vs_ak135(106) = 6.48220000000000
+ Mak135_V%vs_ak135(107) = 6.45140000000000
+ Mak135_V%vs_ak135(108) = 6.41820000000000
+ Mak135_V%vs_ak135(109) = 6.38600000000000
+ Mak135_V%vs_ak135(110) = 6.35190000000000
+ Mak135_V%vs_ak135(111) = 6.31640000000000
+ Mak135_V%vs_ak135(112) = 6.27990000000000
+ Mak135_V%vs_ak135(113) = 6.24240000000000
+ Mak135_V%vs_ak135(114) = 6.21000000000000
+ Mak135_V%vs_ak135(115) = 6.08980000000000
+ Mak135_V%vs_ak135(116) = 5.96070000000000
+ Mak135_V%vs_ak135(117) = 5.61040000000000
+ Mak135_V%vs_ak135(118) = 5.50470000000000
+ Mak135_V%vs_ak135(119) = 5.39890000000000
+ Mak135_V%vs_ak135(120) = 5.29220000000000
+ Mak135_V%vs_ak135(121) = 5.18640000000000
+ Mak135_V%vs_ak135(122) = 5.08060000000000
+ Mak135_V%vs_ak135(123) = 4.87020000000000
+ Mak135_V%vs_ak135(124) = 4.78320000000000
+ Mak135_V%vs_ak135(125) = 4.69640000000000
+ Mak135_V%vs_ak135(126) = 4.60940000000000
+ Mak135_V%vs_ak135(127) = 4.51840000000000
+ Mak135_V%vs_ak135(128) = 4.51840000000000
+ Mak135_V%vs_ak135(129) = 4.50900000000000
+ Mak135_V%vs_ak135(130) = 4.50000000000000
+ Mak135_V%vs_ak135(131) = 4.49000000000000
+ Mak135_V%vs_ak135(132) = 4.48000000000000
+ Mak135_V%vs_ak135(133) = 3.85000000000000
+ Mak135_V%vs_ak135(134) = 3.85000000000000
+ Mak135_V%vs_ak135(135) = 3.46000000000000
+ Mak135_V%vs_ak135(136) = 3.46000000000000
+
+ 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) = 609.740000000000
+ Mak135_V%Qkappa_ak135( 14) = 611.180000000000
+ Mak135_V%Qkappa_ak135( 15) = 612.620000000000
+ Mak135_V%Qkappa_ak135( 16) = 614.210000000000
+ Mak135_V%Qkappa_ak135( 17) = 615.930000000000
+ Mak135_V%Qkappa_ak135( 18) = 617.780000000000
+ Mak135_V%Qkappa_ak135( 19) = 619.710000000000
+ Mak135_V%Qkappa_ak135( 20) = 621.500000000000
+ Mak135_V%Qkappa_ak135( 21) = 624.080000000000
+ Mak135_V%Qkappa_ak135( 22) = 626.870000000000
+ Mak135_V%Qkappa_ak135( 23) = 629.890000000000
+ Mak135_V%Qkappa_ak135( 24) = 633.260000000000
+ Mak135_V%Qkappa_ak135( 25) = 57822.0000000000
+ 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) = 723.120000000000
+ Mak135_V%Qkappa_ak135( 71) = 725.110000000000
+ Mak135_V%Qkappa_ak135( 72) = 726.870000000000
+ Mak135_V%Qkappa_ak135( 73) = 722.730000000000
+ Mak135_V%Qkappa_ak135( 74) = 933.210000000000
+ Mak135_V%Qkappa_ak135( 75) = 940.880000000000
+ Mak135_V%Qkappa_ak135( 76) = 952.000000000000
+ Mak135_V%Qkappa_ak135( 77) = 960.360000000000
+ Mak135_V%Qkappa_ak135( 78) = 968.460000000000
+ Mak135_V%Qkappa_ak135( 79) = 976.810000000000
+ Mak135_V%Qkappa_ak135( 80) = 985.630000000000
+ Mak135_V%Qkappa_ak135( 81) = 990.770000000000
+ Mak135_V%Qkappa_ak135( 82) = 999.440000000000
+ Mak135_V%Qkappa_ak135( 83) = 1008.79000000000
+ Mak135_V%Qkappa_ak135( 84) = 1018.38000000000
+ Mak135_V%Qkappa_ak135( 85) = 1032.14000000000
+ Mak135_V%Qkappa_ak135( 86) = 1042.07000000000
+ Mak135_V%Qkappa_ak135( 87) = 1048.09000000000
+ Mak135_V%Qkappa_ak135( 88) = 1058.03000000000
+ Mak135_V%Qkappa_ak135( 89) = 1064.23000000000
+ Mak135_V%Qkappa_ak135( 90) = 1070.38000000000
+ Mak135_V%Qkappa_ak135( 91) = 1085.97000000000
+ Mak135_V%Qkappa_ak135( 92) = 1097.16000000000
+ Mak135_V%Qkappa_ak135( 93) = 1108.58000000000
+ Mak135_V%Qkappa_ak135( 94) = 1120.09000000000
+ Mak135_V%Qkappa_ak135( 95) = 1127.02000000000
+ Mak135_V%Qkappa_ak135( 96) = 1134.01000000000
+ Mak135_V%Qkappa_ak135( 97) = 1141.32000000000
+ Mak135_V%Qkappa_ak135( 98) = 1148.76000000000
+ Mak135_V%Qkappa_ak135( 99) = 1156.04000000000
+ Mak135_V%Qkappa_ak135(100) = 1163.16000000000
+ Mak135_V%Qkappa_ak135(101) = 1170.53000000000
+ Mak135_V%Qkappa_ak135(102) = 1178.19000000000
+ Mak135_V%Qkappa_ak135(103) = 1186.06000000000
+ Mak135_V%Qkappa_ak135(104) = 1193.99000000000
+ Mak135_V%Qkappa_ak135(105) = 1202.04000000000
+ Mak135_V%Qkappa_ak135(106) = 1210.02000000000
+ Mak135_V%Qkappa_ak135(107) = 1217.91000000000
+ Mak135_V%Qkappa_ak135(108) = 1226.52000000000
+ Mak135_V%Qkappa_ak135(109) = 1234.54000000000
+ Mak135_V%Qkappa_ak135(110) = 1243.02000000000
+ Mak135_V%Qkappa_ak135(111) = 1251.69000000000
+ Mak135_V%Qkappa_ak135(112) = 1260.68000000000
+ Mak135_V%Qkappa_ak135(113) = 1269.44000000000
+ Mak135_V%Qkappa_ak135(114) = 1277.93000000000
+ Mak135_V%Qkappa_ak135(115) = 1311.17000000000
+ Mak135_V%Qkappa_ak135(116) = 1350.54000000000
+ Mak135_V%Qkappa_ak135(117) = 428.690000000000
+ Mak135_V%Qkappa_ak135(118) = 425.510000000000
+ Mak135_V%Qkappa_ak135(119) = 422.550000000000
+ Mak135_V%Qkappa_ak135(120) = 419.940000000000
+ Mak135_V%Qkappa_ak135(121) = 417.320000000000
+ Mak135_V%Qkappa_ak135(122) = 413.660000000000
+ Mak135_V%Qkappa_ak135(123) = 377.930000000000
+ Mak135_V%Qkappa_ak135(124) = 366.340000000000
+ Mak135_V%Qkappa_ak135(125) = 355.850000000000
+ Mak135_V%Qkappa_ak135(126) = 346.370000000000
+ Mak135_V%Qkappa_ak135(127) = 338.470000000000
+ Mak135_V%Qkappa_ak135(128) = 200.970000000000
+ Mak135_V%Qkappa_ak135(129) = 188.720000000000
+ Mak135_V%Qkappa_ak135(130) = 182.570000000000
+ Mak135_V%Qkappa_ak135(131) = 182.030000000000
+ Mak135_V%Qkappa_ak135(132) = 182.030000000000
+ Mak135_V%Qkappa_ak135(133) = 972.770000000000
+ Mak135_V%Qkappa_ak135(134) = 972.770000000000
+ Mak135_V%Qkappa_ak135(135) = 1368.02000000000
+ Mak135_V%Qkappa_ak135(136) = 1368.02000000000
+
+ 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) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 26) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 27) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 28) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 29) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 30) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 31) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 32) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 33) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 34) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 35) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 36) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 37) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 38) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 39) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 40) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 41) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 42) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 43) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 44) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 45) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 46) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 47) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 48) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 49) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 50) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 51) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 52) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 53) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 54) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 55) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 56) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 57) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 58) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 59) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 60) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 61) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 62) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 63) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 64) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 65) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 66) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 67) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 68) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 69) = 0.000000000000000E+000
+ Mak135_V%Qmu_ak135( 70) = 273.970000000000
+ Mak135_V%Qmu_ak135( 71) = 273.970000000000
+ Mak135_V%Qmu_ak135( 72) = 273.970000000000
+ Mak135_V%Qmu_ak135( 73) = 271.740000000000
+ Mak135_V%Qmu_ak135( 74) = 350.880000000000
+ Mak135_V%Qmu_ak135( 75) = 354.610000000000
+ Mak135_V%Qmu_ak135( 76) = 359.710000000000
+ Mak135_V%Qmu_ak135( 77) = 363.640000000000
+ Mak135_V%Qmu_ak135( 78) = 367.650000000000
+ Mak135_V%Qmu_ak135( 79) = 371.750000000000
+ Mak135_V%Qmu_ak135( 80) = 375.940000000000
+ Mak135_V%Qmu_ak135( 81) = 378.790000000000
+ Mak135_V%Qmu_ak135( 82) = 383.140000000000
+ Mak135_V%Qmu_ak135( 83) = 387.600000000000
+ Mak135_V%Qmu_ak135( 84) = 392.160000000000
+ Mak135_V%Qmu_ak135( 85) = 398.410000000000
+ Mak135_V%Qmu_ak135( 86) = 403.230000000000
+ Mak135_V%Qmu_ak135( 87) = 406.500000000000
+ Mak135_V%Qmu_ak135( 88) = 411.520000000000
+ Mak135_V%Qmu_ak135( 89) = 414.940000000000
+ Mak135_V%Qmu_ak135( 90) = 418.410000000000
+ Mak135_V%Qmu_ak135( 91) = 425.530000000000
+ Mak135_V%Qmu_ak135( 92) = 431.030000000000
+ Mak135_V%Qmu_ak135( 93) = 436.680000000000
+ Mak135_V%Qmu_ak135( 94) = 442.480000000000
+ Mak135_V%Qmu_ak135( 95) = 446.430000000000
+ Mak135_V%Qmu_ak135( 96) = 450.450000000000
+ Mak135_V%Qmu_ak135( 97) = 454.550000000000
+ Mak135_V%Qmu_ak135( 98) = 458.720000000000
+ Mak135_V%Qmu_ak135( 99) = 462.960000000000
+ Mak135_V%Qmu_ak135(100) = 467.290000000000
+ Mak135_V%Qmu_ak135(101) = 471.700000000000
+ Mak135_V%Qmu_ak135(102) = 476.190000000000
+ Mak135_V%Qmu_ak135(103) = 480.770000000000
+ Mak135_V%Qmu_ak135(104) = 485.440000000000
+ Mak135_V%Qmu_ak135(105) = 490.200000000000
+ Mak135_V%Qmu_ak135(106) = 495.050000000000
+ Mak135_V%Qmu_ak135(107) = 500.000000000000
+ Mak135_V%Qmu_ak135(108) = 505.050000000000
+ Mak135_V%Qmu_ak135(109) = 510.200000000000
+ Mak135_V%Qmu_ak135(110) = 515.460000000000
+ Mak135_V%Qmu_ak135(111) = 520.830000000000
+ Mak135_V%Qmu_ak135(112) = 526.320000000000
+ Mak135_V%Qmu_ak135(113) = 531.910000000000
+ Mak135_V%Qmu_ak135(114) = 537.630000000000
+ Mak135_V%Qmu_ak135(115) = 543.480000000000
+ Mak135_V%Qmu_ak135(116) = 549.450000000000
+ Mak135_V%Qmu_ak135(117) = 172.930000000000
+ Mak135_V%Qmu_ak135(118) = 170.820000000000
+ Mak135_V%Qmu_ak135(119) = 168.780000000000
+ Mak135_V%Qmu_ak135(120) = 166.800000000000
+ Mak135_V%Qmu_ak135(121) = 164.870000000000
+ Mak135_V%Qmu_ak135(122) = 162.500000000000
+ Mak135_V%Qmu_ak135(123) = 146.570000000000
+ Mak135_V%Qmu_ak135(124) = 142.760000000000
+ Mak135_V%Qmu_ak135(125) = 139.380000000000
+ Mak135_V%Qmu_ak135(126) = 136.380000000000
+ Mak135_V%Qmu_ak135(127) = 133.720000000000
+ Mak135_V%Qmu_ak135(128) = 79.4000000000000
+ Mak135_V%Qmu_ak135(129) = 76.5500000000000
+ Mak135_V%Qmu_ak135(130) = 76.0600000000000
+ Mak135_V%Qmu_ak135(131) = 75.6000000000000
+ Mak135_V%Qmu_ak135(132) = 75.6000000000000
+ Mak135_V%Qmu_ak135(133) = 403.930000000000
+ Mak135_V%Qmu_ak135(134) = 403.930000000000
+ Mak135_V%Qmu_ak135(135) = 599.990000000000
+ Mak135_V%Qmu_ak135(136) = 599.990000000000
+
+! strip the crust and replace it with mantle
+ if (SUPPRESS_CRUSTAL_MESH .or. USE_EXTERNAL_CRUSTAL_MODEL) then
+ Mak135_V%vp_ak135(133:136) = Mak135_V%vp_ak135(132)
+ Mak135_V%vs_ak135(133:136) = Mak135_V%vs_ak135(132)
+ Mak135_V%density_ak135(133:136) = Mak135_V%density_ak135(132)
+ Mak135_V%Qkappa_ak135(133:136) = Mak135_V%Qkappa_ak135(132)
+ Mak135_V%Qmu_ak135(133:136) = Mak135_V%Qmu_ak135(132)
+ endif
+
+ end subroutine define_model_ak135
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_aniso_inner_core.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_inner_core.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_aniso_inner_core.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_aniso_inner_core.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+!
+! based on scaling factors by Ishii et al. (2002)
+!
+! one should add an MPI_BCAST in meshfem3D_models.f90 if one
+! adds a 3D model or a read_aniso_inner_core_model subroutine
+!--------------------------------------------------------------------------------------------------
+
+ subroutine model_aniso_inner_core(x,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL, &
+ vpv,vph,vsv,vsh,rho,eta_aniso)
+
+ 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 rho,vpv,vph,vsv,vsh,eta_aniso
+
+ ! local parameters
+ double precision vp,vs
+ double precision vpc,vsc,rhoc
+ double precision vp0,vs0,rho0,A0
+ double precision c66
+ double precision scale_fac
+
+ ! calculates isotropic values from given (transversely isotropic) reference values
+ ! (are non-dimensionalized)
+ 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)
+
+ ! scale to dimensions (e.g. used in prem model)
+ scale_fac = R_EARTH*dsqrt(PI*GRAV*RHOAV)/1000.d0
+ vp = vp * scale_fac
+ vs = vs * scale_fac
+ rho = rho * RHOAV/1000.d0
+
+ select case(REFERENCE_1D_MODEL)
+
+ case(REFERENCE_MODEL_IASP91)
+ vpc=11.24094d0-4.09689d0*x*x
+ vsc=3.56454d0-3.45241d0*x*x
+ rhoc=13.0885d0-8.8381d0*x*x
+ ! checks with given values
+ if( abs(vpc-vp) > TINYVAL .or. abs(vsc-vs) > TINYVAL .or. abs(rhoc-rho) > TINYVAL) then
+ stop 'error isotropic IASP91 values in model_aniso_inner_core() '
+ endif
+
+ ! values at center
+ vp0=11.24094d0
+ vs0=3.56454d0
+ rho0=13.0885d0
+
+ case(REFERENCE_MODEL_PREM)
+ vpc=11.2622d0-6.3640d0*x*x
+ vsc=3.6678d0-4.4475d0*x*x
+ rhoc=13.0885d0-8.8381d0*x*x
+ ! checks
+ if( abs(vpc-vp) > TINYVAL .or. abs(vsc-vs) > TINYVAL .or. abs(rhoc-rho) > TINYVAL) then
+ stop 'error isotropic PREM values in model_aniso_inner_core() '
+ endif
+
+ ! values at center
+ vp0=11.2622d0
+ vs0=3.6678d0
+ rho0=13.0885d0
+
+ case(REFERENCE_MODEL_1DREF)
+ ! values at center
+ vp0 = 11262.20 / 1000.0d0
+ vs0 = 3667.800 / 1000.0d0
+ rho0 = 13088.480 / 1000.0d0
+
+ case(REFERENCE_MODEL_1066A)
+ ! values at center
+ vp0 = 11.33830
+ vs0 = 3.62980
+ rho0 = 13.429030
+
+ case(REFERENCE_MODEL_AK135)
+ ! values at center
+ vp0 = 11.26220
+ vs0 = 3.667800
+ rho0 = 13.01220
+
+ case(REFERENCE_MODEL_JP1D)
+ ! values at center
+ vp0 = 11.24094
+ vs0 = 3.56454
+ rho0 = 13.0885d0
+
+ case(REFERENCE_MODEL_SEA1D)
+ ! values at center
+ vp0 = 11.240940
+ vs0 = 3.564540
+ rho0 = 13.012190
+
+ case default
+ stop 'unknown 1D reference Earth model in anisotropic inner core'
+
+ end select
+
+! non-dimensionalization of elastic parameters (GPa--[g/cm^3][(km/s)^2])
+ scale_fac = RHOAV*R_EARTH*R_EARTH*PI*GRAV*RHOAV
+ scale_fac = 1.d9 / scale_fac
+
+! 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
+
+! 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
+! and c12 = c11 - 2*c66
+!
+! 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*scale_fac
+ c66 = rho*vs*vs*scale_fac
+ c12 = c11 - 2.0d0*c66
+
+ A0 = rho0*vp0*vp0*scale_fac
+
+ c33 = c11 + 0.0349d0*A0
+ c44 = c66 + 0.00988d0*A0
+ c13 = c12 - 0.00881d0*A0
+
+ end subroutine model_aniso_inner_core
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_aniso_mantle.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_mantle.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_aniso_mantle.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_aniso_mantle.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,907 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+!
+! 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 model_aniso_mantle_broadcast(myrank,AMM_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+ ! model_aniso_mantle_variables
+ type model_aniso_mantle_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ integer dummy_pad ! padding 4 bytes to align the structure
+ end type model_aniso_mantle_variables
+
+ type (model_aniso_mantle_variables) AMM_V
+ ! model_aniso_mantle_variables
+
+ integer :: myrank
+ integer :: ier
+
+ ! 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)
+
+
+ end subroutine model_aniso_mantle_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine model_aniso_mantle(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"
+
+! model_aniso_mantle_variables
+ type model_aniso_mantle_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ integer dummy_pad ! padding 4 bytes to align the structure
+ end type model_aniso_mantle_variables
+
+ type (model_aniso_mantle_variables) AMM_V
+! model_aniso_mantle_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 model_aniso_mantle
+
+!--------------------------------------------------------------------
+
+ 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"
+
+! model_aniso_mantle_variables
+ type model_aniso_mantle_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ integer dummy_pad ! padding 4 bytes to align the structure
+ end type model_aniso_mantle_variables
+
+ type (model_aniso_mantle_variables) AMM_V
+! model_aniso_mantle_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/src/model_atten3D_QRFSI12.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_atten3D_QRFSI12.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_atten3D_QRFSI12.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_atten3D_QRFSI12.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,736 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+!
+! This file contains subroutines to read in and get values for
+! 3-D attenuation model QRFSI12 (Dalton, Ekstrom, & Dziewonski, 2008)
+!
+! C.A. Dalton, G. Ekstr\"om and A.M. Dziewonski, 2008.
+! The global attenuation structure of the upper mantle,
+! J. Geophys. Res., 113, B05317,10.1029/2006JB004394
+!
+! Last edit: Colleen Dalton, March 25, 2008
+!
+! Q1: what are theta and phi?
+! Q2: units for radius?
+! Q3: what to do about core?
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_atten3D_QRFSI12_broadcast(myrank,QRFSI12_Q)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+ ! model_atten3D_QRFSI12_variables
+ type model_atten3D_QRFSI12_variables
+ sequence
+ double precision dqmu(NKQ,NSQ)
+ double precision spknt(NKQ)
+ double precision refdepth(NDEPTHS_REFQ)
+ double precision refqmu(NDEPTHS_REFQ)
+ end type model_atten3D_QRFSI12_variables
+
+ type (model_atten3D_QRFSI12_variables) QRFSI12_Q
+ ! model_atten3D_QRFSI12_variables
+
+ integer :: myrank
+ integer :: ier
+
+ if(myrank == 0) call read_atten_model_3D_QRFSI12(QRFSI12_Q)
+
+ call MPI_BCAST(QRFSI12_Q%dqmu, NKQ*NSQ,MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(QRFSI12_Q%spknt, NKQ,MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(QRFSI12_Q%refdepth, NDEPTHS_REFQ,MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(QRFSI12_Q%refqmu, NDEPTHS_REFQ,MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+
+ if(myrank == 0) write(IMAIN,*) 'read 3D attenuation model'
+
+
+ end subroutine
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_atten_model_3D_QRFSI12(QRFSI12_Q)
+
+ implicit none
+
+ include "constants.h"
+
+! three_d_model_atten3D_QRFSI12_variables
+ type model_atten3D_QRFSI12_variables
+ sequence
+ double precision dqmu(NKQ,NSQ)
+ double precision spknt(NKQ)
+ double precision refdepth(NDEPTHS_REFQ)
+ double precision refqmu(NDEPTHS_REFQ)
+ end type model_atten3D_QRFSI12_variables
+
+ type (model_atten3D_QRFSI12_variables) QRFSI12_Q
+! three_d_model_atten3D_QRFSI12_variables
+
+ integer j,k,l,m
+ integer index,ll,mm
+ double precision v1,v2
+
+ character(len=150) QRFSI12,QRFSI12_ref
+
+! read in QRFSI12
+! hard-wire for now
+ QRFSI12='DATA/QRFSI12/QRFSI12.dat'
+ QRFSI12_ref='DATA/QRFSI12/ref_QRFSI12'
+
+! get the dq model coefficients
+ open(unit=10,file=QRFSI12,status='old',action='read')
+ do k=1,NKQ
+ read(10,*)index
+ j=0
+ do l=0,MAXL_Q
+ do m=0,l
+ if(m.eq.0)then
+ j=j+1
+ read(10,*)ll,mm,v1
+ QRFSI12_Q%dqmu(k,j)=v1
+ else
+ j=j+2
+ read(10,*)ll,mm,v1,v2
+ ! write(*,*) 'k,l,m,ll,mm:',k,l,m,ll,mm,v1
+ QRFSI12_Q%dqmu(k,j-1)=2.*v1
+ QRFSI12_Q%dqmu(k,j)=-2.*v2
+ endif
+ enddo
+ enddo
+ enddo
+ close(10)
+
+! get the depths (km) of the spline knots
+ QRFSI12_Q%spknt(1) = 24.4
+ QRFSI12_Q%spknt(2) = 75.0
+ QRFSI12_Q%spknt(3) = 150.0
+ QRFSI12_Q%spknt(4) = 225.0
+ QRFSI12_Q%spknt(5) = 300.0
+ QRFSI12_Q%spknt(6) = 410.0
+ QRFSI12_Q%spknt(7) = 530.0
+ QRFSI12_Q%spknt(8) = 650.0
+
+! get the depths and 1/Q values of the reference model
+ open(11,file=QRFSI12_ref,status='old',action='read')
+ do j=1,NDEPTHS_REFQ
+ read(11,*)QRFSI12_Q%refdepth(j),QRFSI12_Q%refqmu(j)
+ enddo
+ close(11)
+
+
+ end subroutine read_atten_model_3D_QRFSI12
+
+!----------------------------------
+!----------------------------------
+
+ subroutine model_atten3D_QRFSI12(radius,theta,phi,Qmu,QRFSI12_Q,idoubling)
+
+ implicit none
+
+ include "constants.h"
+
+! model_atten3D_QRFSI12_variables
+ type model_atten3D_QRFSI12_variables
+ sequence
+ double precision dqmu(NKQ,NSQ)
+ double precision spknt(NKQ)
+ double precision refdepth(NDEPTHS_REFQ)
+ double precision refqmu(NDEPTHS_REFQ)
+ end type model_atten3D_QRFSI12_variables
+
+ type (model_atten3D_QRFSI12_variables) QRFSI12_Q
+! model_atten3D_QRFSI12_variables
+
+ integer i,j,k,n,idoubling
+ integer ifnd
+ double precision radius,theta,phi,Qmu,smallq,dqmu,smallq_ref
+ real(kind=4) splpts(NKQ),splcon(NKQ),splcond(NKQ)
+ real(kind=4) depth,ylat,xlon
+ real(kind=4) shdep(NSQ)
+ real(kind=4) xlmvec(NSQ),wk1(NSQ),wk2(NSQ),wk3(NSQ)
+ double precision, parameter :: rmoho_prem = 6371.0-24.4
+ double precision, parameter :: rcmb = 3480.0
+
+ !in Colleen's original code theta refers to the latitude. Here we have redefined theta to be colatitude
+ !to agree with the rest of specfem
+! print *,'entering QRFSI12 subroutine'
+
+ ylat=90.0d0-theta
+ xlon=phi
+
+! only checks radius for crust, idoubling is missleading for oceanic crust when we want to expand mantle up to surface...
+! !if(idoubling == IFLAG_CRUST .or. radius >= rmoho) then
+ if( radius >= rmoho_prem ) then
+ ! print *,'QRFSI12: we are in the crust'
+ Qmu = 600.0d0
+ else if(idoubling == IFLAG_INNER_CORE_NORMAL .or. idoubling == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling == IFLAG_BOTTOM_CENTRAL_CUBE .or. idoubling == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling == IFLAG_IN_FICTITIOUS_CUBE) then
+ ! print *,'QRFSI12: we are in the inner core'
+ Qmu = 84.6d0
+ else if(idoubling == IFLAG_OUTER_CORE_NORMAL) then
+ ! print *,'QRFSI12: we are in the outer core'
+ Qmu = 0.0d0
+ else !we are in the mantle
+ depth = 6371.-radius
+! print *,'QRFSI12: we are in the mantle at depth',depth
+ ifnd=0
+ do i=2,NDEPTHS_REFQ
+ if(depth >= QRFSI12_Q%refdepth(i-1) .and. depth < QRFSI12_Q%refdepth(i))then
+ ifnd=i
+ endif
+ enddo
+ if(ifnd == 0)then
+ write(6,"('problem finding reference Q value at depth: ',f8.3)") depth
+ stop
+ endif
+ smallq_ref=QRFSI12_Q%refqmu(ifnd)
+ smallq = smallq_ref
+
+ if(depth < 650.d0) then !Colleen's model is only defined between depths of 24.4 and 650km
+ do j=1,NSQ
+ shdep(j)=0.
+ enddo
+ do n=1,NKQ
+ splpts(n)=QRFSI12_Q%spknt(n)
+ enddo
+ call vbspl(depth,NKQ,splpts,splcon,splcond)
+ do n=1,NKQ
+ do j=1,NSQ
+ shdep(j)=shdep(j)+(splcon(n)*QRFSI12_Q%dqmu(n,j))
+ enddo
+ enddo
+ call ylm(ylat,xlon,MAXL_Q,xlmvec,wk1,wk2,wk3)
+ dqmu=0.
+ do k=1,NSQ
+ dqmu=dqmu+xlmvec(k)*shdep(k)
+ enddo
+ smallq = smallq_ref + dqmu
+ endif
+ ! if smallq is small and negative (due to numerical error), Qmu is very large:
+ if(smallq < 0.0d0) smallq = 1.0d0/ATTENUATION_COMP_MAXIMUM
+ Qmu = 1/smallq
+ ! Qmu is larger than MAX_ATTENUATION_VALUE, set it to ATTENUATION_COMP_MAXIMUM. This assumes that this
+ ! value is high enough that at this point there is almost no attenuation at all.
+ if(Qmu >= ATTENUATION_COMP_MAXIMUM) Qmu = 0.99d0*ATTENUATION_COMP_MAXIMUM
+
+ endif
+
+ end subroutine model_atten3D_QRFSI12
+
+!----------------------------------
+!----------------------------------
+
+!!$ 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
+!!$
+!!$ integer :: L,M,i,k,LP1,MP1
+!!$ real(kind=4) :: THETA,X,XP,XCOSEC,SFL3
+!!$
+!!$ DIMENSION X(2),XP(2),XCOSEC(2)
+!!$ DOUBLE PRECISION SMALL,SUM,COMPAR,CT,ST,FCT,COT,FPI,X1,X2,X3,F1,F2,XM,TH,DSFL3,COSEC
+!!$ DATA FPI/12.56637062D0/
+!!$! DFLOAT(I)=FLOAT(I)
+!!$ SUM=0.D0
+!!$ LP1=L+1
+!!$ TH=THETA
+!!$ CT=DCOS(TH)
+!!$ ST=DSIN(TH)
+!!$ MP1=M+1
+!!$ FCT=DSQRT(dble(FLOAT(2*L+1))/FPI)
+!!$ SFL3=SQRT(FLOAT(L*(L+1)))
+!!$ COMPAR=dble(FLOAT(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.GT.1.AND.ABS(THETA).GT.1.E-5) GO TO 3
+!!$ X(1)=FCT
+!!$ IF(L.EQ.0) RETURN
+!!$ X(1)=CT*FCT
+!!$ X(2)=-ST*FCT/DSFL3
+!!$ XP(1)=-ST*FCT
+!!$ XP(2)=-.5D0*CT*FCT*DSFL3
+!!$ IF(ABS(THETA).LT.1.E-5) XCOSEC(2)=XP(2)
+!!$ IF(ABS(THETA).GE.1.E-5) XCOSEC(2)=X(2)/ST
+!!$ RETURN
+!!$ 3 X1=1.D0
+!!$ X2=CT
+!!$ DO I=2,L
+!!$ X3=(dble(FLOAT(2*I-1))*CT*X2-dble(FLOAT(I-1))*X1)/dble(FLOAT(I))
+!!$ X1=X2
+!!$ X2=X3
+!!$ enddo
+!!$ COT=CT/ST
+!!$ COSEC=1./ST
+!!$ X3=X2*FCT
+!!$ X2=dble(FLOAT(L))*(X1-CT*X2)*FCT/ST
+!!$ X(1)=X3
+!!$ X(2)=X2
+!!$ SUM=X3*X3
+!!$ XP(1)=-X2
+!!$ XP(2)=dble(FLOAT(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.GT.SMALL) RETURN
+!!$ X1=X3
+!!$ X2=-X2/DSQRT(dble(FLOAT(L*(L+1))))
+!!$ DO I=3,MP1
+!!$ K=I-1
+!!$ F1=DSQRT(dble(FLOAT((L+I-1)*(L-I+2))))
+!!$ F2=DSQRT(dble(FLOAT((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.GT.SMALL.AND.I.NE.LP1) RETURN
+!!$ X(I)=X3
+!!$ XCOSEC(I)=X(I)*COSEC
+!!$ X1=X2
+!!$ XP(I)=-(F1*X2+XM*COT*X3)
+!!$ X2=X3
+!!$ enddo
+!!$ RETURN
+!!$ end subroutine legndr
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_attenuation.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_attenuation.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_attenuation.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_attenuation.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1485 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+!
+! 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 model_attenuation_broadcast(myrank,AM_V,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+! model_attenuation_variables
+ type model_attenuation_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
+ 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, dimension(:), pointer :: interval_Q ! Steps
+ integer :: Qn ! Number of points
+ integer dummy_pad ! padding 4 bytes to align the structure
+ end type model_attenuation_variables
+
+ type (model_attenuation_variables) AM_V
+! model_attenuation_variables
+
+ integer :: MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
+ integer :: myrank
+ integer :: ier
+
+ if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V)
+
+ if(myrank /= 0) allocate(AM_V%Qtau_s(N_SLS))
+ 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)
+
+
+ end subroutine
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_attenuation_model(min_att_period, max_att_period, AM_V)
+
+ implicit none
+
+ include 'constants.h'
+
+! model_attenuation_variables
+ type model_attenuation_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
+ 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, dimension(:), pointer :: interval_Q ! Steps
+ integer :: Qn ! Number of points
+ integer dummy_pad ! padding 4 bytes to align the structure
+ end type model_attenuation_variables
+
+ type (model_attenuation_variables) AM_V
+! model_attenuation_variables
+
+ integer min_att_period, max_att_period
+
+ AM_V%min_period = min_att_period * 1.0d0
+ AM_V%max_period = max_att_period * 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
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! 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 model_attenuation_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'
+
+! model_attenuation_variables
+ type model_attenuation_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
+ 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, dimension(:), pointer :: interval_Q ! Steps
+ integer :: Qn ! Number of points
+ integer dummy_pad ! padding 4 bytes to align the structure
+ end type model_attenuation_variables
+
+ type (model_attenuation_variables) AM_V
+! model_attenuation_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_1dref_variables
+ type model_1dref_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_1dref_variables
+
+ type (model_1dref_variables) Mref_V
+! model_1dref_variables
+
+! model_sea1d_variables
+ type model_sea1d_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 model_sea1d_variables
+
+ type (model_sea1d_variables) SEA1DM_V
+! model_sea1d_variables
+
+! model_attenuation_storage_var
+ type model_attenuation_storage_var
+ sequence
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ integer Q_resolution
+ integer Q_max
+ end type model_attenuation_storage_var
+
+ type (model_attenuation_storage_var) AM_S
+! model_attenuation_storage_var
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ 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
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = 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 ! as defined by IASP91
+
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+ if(myrank > 0) return
+
+
+ ! uses "pure" 1D models including their 1D-crust profiles
+ ! (uses USE_EXTERNAL_CRUSTAL_MODEL set to false)
+ 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_1DREF) then
+ call define_model_1dref(.FALSE.,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
+
+ ! sets up attenuation storage (for all possible Qmu values defined in the 1D models)
+ 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_1DREF) 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 model_attenuation_getstored_tau(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 model_attenuation_setup
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_attenuation_getstored_tau(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'
+
+! model_attenuation_variables
+ type model_attenuation_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
+ 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, dimension(:), pointer :: interval_Q ! Steps
+ integer :: Qn ! Number of points
+ integer dummy_pad ! padding 4 bytes to align the structure
+ end type model_attenuation_variables
+
+ type (model_attenuation_variables) AM_V
+! model_attenuation_variables
+
+! model_attenuation_storage_var
+ type model_attenuation_storage_var
+ sequence
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ integer Q_resolution
+ integer Q_max
+ end type model_attenuation_storage_var
+
+ type (model_attenuation_storage_var) AM_S
+! model_attenuation_storage_var
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ 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
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = 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 model_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 model_attenuation_storage(Qmu_in, tau_e, rw, AM_S)
+
+ end subroutine model_attenuation_getstored_tau
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_attenuation_storage(Qmu, tau_e, rw, AM_S)
+
+ implicit none
+ include 'mpif.h'
+ include 'constants.h'
+
+! model_attenuation_storage_var
+ type model_attenuation_storage_var
+ sequence
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ integer Q_resolution
+ integer Q_max
+ end type model_attenuation_storage_var
+
+ type (model_attenuation_storage_var) AM_S
+! model_attenuation_storage_var
+
+ 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 attenuation_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;
+
+ ! by default: resolution is Q_resolution = 10
+ ! converts Qmu to an array integer index:
+ ! e.g. Qmu = 150.31 -> Qtmp = 150.31 * 10 = int( 1503.10 ) = 1503
+ Qtmp = Qmu * dble(AM_S%Q_resolution)
+
+ ! rounds to corresponding double value:
+ ! e.g. Qmu_new = dble( 1503 ) / dble(10) = 150.30
+ ! but Qmu_new is not used any further...
+ 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 model_attenuation_storage
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ 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
+ 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
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = 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
+ 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
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = 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
+ 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
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = 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
+ 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
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = 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
+ 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
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = 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_local(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_local(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_local(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_local
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+! unused routines...
+!
+!
+! subroutine model_attenuation_1D_PREM(x, Qmu)
+!
+!! x is 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
+!
+!! Since R80 may be changed, we use radius to decide the attenuation region
+!! rather than doubling flag
+!
+! ! 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 model_attenuation_1D_PREM
+!
+!!
+!!-------------------------------------------------------------------------------------------------
+!!
+!
+!! get 1D REF attenuation model according to radius
+! subroutine model_attenuation_1D_REF(x, Qmu)
+!
+!! x in the radius from 0 to 1 where 0 is the center and 1 is the surface
+!! This version is for 1D REF.
+!
+! implicit none
+!
+! include 'constants.h'
+!
+! 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 = 5961000.d0
+! R600 = 5771000.d0
+! R670 = 5721000.d0
+! R771 = 5600000.d0
+! RTOPDDOUBLEPRIME = 3630000.d0
+! RCMB = 3479958.d0
+! RICB = 1221491.d0
+!
+!! REF model
+!!
+!!--- inner core
+!!
+! if(r >= 0.d0 .and. r <= RICB) then
+! Qmu=104.0d0
+! Qkappa=1327.6d0
+!
+!!--- outer core
+!!
+! else if(r > RICB .and. r <= RCMB) then
+! Qmu=0.0d0
+! Qkappa=57822.5d0
+! if(RCMB - r < r - RICB) then
+! Qmu = 355.0d0 ! CMB
+! else
+! Qmu = 104.0d0 ! ICB
+! endif
+!
+!!--- D" at the base of the mantle
+!!
+! else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+! Qmu=355.0d0
+! Qkappa=57822.5d0
+!
+!!--- mantle: from top of D" to d670
+!!
+! else if(r > RTOPDDOUBLEPRIME .and. r <= R670) then
+! Qmu=355.0d0
+! Qkappa=57822.5d0
+!
+!!--- mantle: above d670
+!!
+! else if(r > R670 .and. r <= R220) then
+! Qmu=165.0d0
+! Qkappa=943.0d0
+! else if(r > R220 .and. r <= R80) then
+! Qmu=70.0d0
+! Qkappa=943.0d0
+! else if(r > R80.and. r<=RMOHO) then
+! Qmu=191.0d0
+! Qkappa=943.0d0
+! else if (r > RMOHO) then
+! Qmu=300.0d0
+! Qkappa=57822.5d0
+! endif
+!
+! end subroutine model_attenuation_1D_REF
+!
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_crust.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_crust.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_crust.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_crust.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! CRUST 2.0 model by Bassin et al. (2000)
+!
+! C. Bassin, G. Laske, and G. Masters.
+! The current limits of resolution for surface wave tomography in North America.
+! EOS, 81: F897, 2000.
+!
+! reads and smooths crust2.0 model
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_crust_broadcast(myrank,CM_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+ ! model_crust_variables
+ type model_crust_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)
+ character(len=2) dummy_pad ! padding 2 bytes to align the structure
+ end type model_crust_variables
+
+ type (model_crust_variables) CM_V
+ ! model_crust_variables
+
+ integer :: myrank
+ integer :: ier
+
+ ! the variables read are declared and stored in structure CM_V
+ if(myrank == 0) call read_crust_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)
+
+
+ end subroutine model_crust_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine model_crust(lat,lon,x,vp,vs,rho,moho,found_crust,CM_V,elem_in_crust)
+
+ implicit none
+ include "constants.h"
+
+! model_crust_variables
+ type model_crust_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)
+ character(len=2) dummy_pad ! padding 2 bytes to align the structure
+ end type model_crust_variables
+
+ type (model_crust_variables) CM_V
+! model_crust_variables
+
+ double precision lat,lon,x,vp,vs,rho,moho
+ logical found_crust,elem_in_crust
+
+ ! local parameters
+ 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)
+
+ ! initializes
+ vp = 0.d0
+ vs = 0.d0
+ rho = 0.d0
+
+ ! gets smoothed crust2.0 structure
+ call crust_CAPsmoothed(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 &
+! .and. h_sed >= MINIMUM_SEDIMENT_THICKNESS) then
+ 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 &
+! .and. h_sed >= MINIMUM_SEDIMENT_THICKNESS) then
+ 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 .or. elem_in_crust) then
+ ! takes lower crustal values only if x is slightly above moho depth or
+ ! if elem_in_crust is set
+ !
+ ! note: it looks like this does distinguish between GLL points at the exact moho boundary,
+ ! where the point is on the interface between both,
+ ! oceanic elements and mantle elements below
+ vp = vps(7)
+ vs = vss(7)
+ rho = rhos(7)
+ else
+ ! note: if x is exactly the moho depth this will return false
+ found_crust = .false.
+ endif
+
+ ! non-dimensionalize
+ if (found_crust) then
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+ vp = vp*1000.0d0/(R_EARTH*scaleval)
+ vs = vs*1000.0d0/(R_EARTH*scaleval)
+ rho = rho*1000.0d0/RHOAV
+ endif
+
+ ! checks moho value
+ !moho = h_uc + thicks(6) + thicks(7)
+ !if( moho /= thicks(NLAYERS_CRUST) ) then
+ ! print*,'moho:',moho,thicks(NLAYERS_CRUST)
+ ! print*,' lat/lon/x:',lat,lon,x
+ !endif
+
+ ! No matter found_crust true or false, output moho thickness
+ moho = (h_uc+thicks(6)+thicks(7))*1000.0d0/R_EARTH
+
+ end subroutine model_crust
+
+!---------------------------
+
+ subroutine read_crust_model(CM_V)
+
+ implicit none
+ include "constants.h"
+
+! model_crust_variables
+ type model_crust_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)
+ character(len=2) dummy_pad ! padding 2 bytes to align the structure
+ end type model_crust_variables
+
+ type (model_crust_variables) CM_V
+! model_crust_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_crust_model'
+
+ end subroutine read_crust_model
+
+!---------------------------
+
+ subroutine crust_CAPsmoothed(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"
+
+ ! sampling rate for CAP points
+ integer, parameter :: NTHETA = 4
+ integer, parameter :: NPHI = 20
+
+ ! 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)
+
+ !-------------------------------
+ ! work-around to avoid jacobian problems when stretching mesh elements;
+ ! one could also try to slightly change the shape of the doulbing element bricks (which cause the problem)...
+ !
+ ! defines a "critical" region around the andes to have at least a 2-degree smoothing;
+ ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
+ double precision,parameter :: LAT_CRITICAL_ANDES = -20.0d0
+ double precision,parameter :: LON_CRITICAL_ANDES = -70.0d0
+ double precision,parameter :: CRITICAL_RANGE = 70.0d0
+ !-------------------------------
+
+ ! local variables
+ 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)
+ double precision weightl,cap_degree,dist
+ double precision h_sed
+ integer i,icolat,ilon,ierr
+ character(len=2) crustaltype
+
+ ! checks latitude/longitude
+ if(lat > 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) &
+ stop 'error in latitude/longitude range in crust'
+
+ ! makes sure lat/lon are within crust2.0 range
+ 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
+
+ ! sets up smoothing points
+ ! by default uses CAP smoothing with 1 degree
+ cap_degree = 1.0d0
+
+ ! checks if inside/outside of critical region for mesh stretching
+ if( SMOOTH_CRUST ) then
+ dist = dsqrt( (lon-LON_CRITICAL_ANDES)**2 + (lat-LAT_CRITICAL_ANDES )**2 )
+ if( dist < CRITICAL_RANGE ) then
+ ! increases cap smoothing degree
+ ! scales between -1 at center and 0 at border
+ dist = dist / CRITICAL_RANGE - 1.0d0
+ ! shifts value to 1 at center and 0 to the border with exponential decay
+ dist = 1.0d0 - exp( - dist*dist*10.0d0 )
+ ! increases smoothing degree inside of critical region to 2 degree
+ cap_degree = cap_degree + dist
+ endif
+ endif
+
+ ! gets smoothing points and weights
+ call CAP_vardegree(lon,lat,xlon,xlat,weight,cap_degree,NTHETA,NPHI)
+
+ ! initializes
+ velp(:) = 0.0d0
+ vels(:) = 0.0d0
+ rho(:) = 0.0d0
+ thick(:) = 0.0d0
+
+ ! loops over weight points
+ do i=1,NTHETA*NPHI
+ ! gets crust values
+ 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'
+
+ ! sediment thickness
+ h_sed = thickl(3) + thickl(4)
+
+ ! takes upper crust value if sediment too thin
+ if( h_sed < MINIMUM_SEDIMENT_THICKNESS ) then
+ velpl(3) = velpl(5)
+ velpl(4) = velpl(5)
+ velsl(3) = velsl(5)
+ velsl(4) = velsl(5)
+ rhol(3) = rhol(5)
+ rhol(4) = rhol(5)
+ endif
+
+ ! weighting value
+ weightl = weight(i)
+
+ ! total, smoothed values
+ rho(:) = rho(:) + weightl*rhol(:)
+ thick(:) = thick(:) + weightl*thickl(:)
+ velp(:) = velp(:) + weightl*velpl(:)
+ vels(:) = vels(:) + weightl*velsl(:)
+ enddo
+
+ end subroutine crust_CAPsmoothed
+
+
+!------------------------------------------------------
+
+ 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
+
+
+!---------------------------
+
+ subroutine CAP_vardegree(lon,lat,xlon,xlat,weight,CAP_DEGREE,NTHETA,NPHI)
+
+! calculates weighting points to smooth around lon/lat location with
+! a smoothing range of CAP_DEGREE
+!
+! The cap is rotated to the North Pole.
+!
+! returns: xlon,xlat,weight
+
+ implicit none
+ include "constants.h"
+
+ ! sampling rate
+ integer :: NTHETA
+ integer :: NPHI
+ ! smoothing size (in degrees)
+ double precision :: CAP_DEGREE
+
+ ! argument variables
+ double precision lat,lon
+ double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
+
+ ! local variables
+ double precision CAP
+ double precision theta,phi,sint,cost,sinp,cosp,wght,total
+ double precision r_rot,theta_rot,phi_rot
+ double precision rotation_matrix(3,3),x(3),xc(3)
+ double precision dtheta,dphi,cap_area,dweight,pi_over_nphi
+ integer i,j,k
+ integer itheta,iphi
+
+ double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
+ double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
+
+ ! initializes
+ xlon(:) = 0.d0
+ xlat(:) = 0.d0
+ weight(:) = 0.d0
+
+ ! checks cap degree size
+ if( CAP_DEGREE < TINYVAL ) then
+ ! no cap smoothing
+ print*,'error cap:',CAP_DEGREE
+ print*,' lat/lon:',lat,lon
+ stop 'error cap_degree too small'
+ endif
+
+ ! pre-compute parameters
+ CAP = CAP_DEGREE * PI/180.0d0
+ dtheta = 0.5d0 * CAP / dble(NTHETA)
+ dphi = TWO_PI / dble(NPHI)
+ cap_area = TWO_PI * (1.0d0 - dcos(CAP))
+ dweight = CAP / dble(NTHETA) * dphi / cap_area
+ pi_over_nphi = PI/dble(NPHI)
+
+ ! colatitude/longitude in radian
+ theta = (90.0d0 - lat ) * DEGREES_TO_RADIANS
+ phi = lon * DEGREES_TO_RADIANS
+
+ sint = dsin(theta)
+ cost = dcos(theta)
+ sinp = dsin(phi)
+ cosp = dcos(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.0d0
+ rotation_matrix(3,3) = cost
+
+ ! calculates points over a cap at the North pole and rotates them to specified lat/lon point
+ i = 0
+ total = 0.0d0
+ do itheta = 1,NTHETA
+
+ theta = dble(2*itheta-1)*dtheta
+ cost = dcos(theta)
+ sint = dsin(theta)
+ wght = sint*dweight
+
+ 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_over_nphi
+ cosp = dcos(phi)
+ sinp = dsin(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.0d0
+ 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_OVER_TWO - theta_rot) * RADIANS_TO_DEGREES
+ xlon(i) = phi_rot * RADIANS_TO_DEGREES
+ if(xlon(i) > 180.0d0) xlon(i) = xlon(i) - 360.0d0
+
+ enddo
+
+ enddo
+ if(abs(total-1.0d0) > 0.001d0) then
+ print*,'error cap:',total,CAP_DEGREE
+ stop 'error in cap integration for variable degree'
+ endif
+
+ end subroutine
+
+
+!---------------------------
+! unused routines...
+!
+! subroutine crust_singlevalue(lat,lon,velp,vels,rho,thick,abbreviation,&
+! code,thlr,velocp,velocs,dens)
+!
+!! crustal vp and vs in km/s, layer thickness in km
+!
+!! uses crust2.0 as is, without smoothing
+!
+! implicit none
+! include "constants.h"
+!
+!! 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 icolat,ilon,ierr
+! 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)
+! if( ierr /= 0 ) stop 'error in routine get_crust_structure'
+!
+! end subroutine crust_singlevalue
+!
+!---------------------------
+!
+!
+! subroutine crust_org(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"
+!! Change the CAP function to smooth crustal model
+! integer, parameter :: NTHETA = 4 !2
+! integer, parameter :: NPHI = 20 !10
+! double precision, parameter :: CAP = 1.0d0*PI/180.0d0 ! 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_org
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_crustmaps.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_crustmaps.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_crustmaps.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_crustmaps.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,757 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! General Crustmaps
+!
+! combines Crust2.0 and EUcrust07 for moho depths; the crustal maps are
+! interpolating the crustal velocities from Crust2.0 onto the more detailed EUcrust
+! crustal depths where ever they are defined.
+
+! current crustmaps (cmaps) take sediment thickness
+! and moho depths from EUcrust07 if possible and interpolate corresponding
+! velocity/densities given from Crust2.0.
+!
+! main author: Matthias Meschede (meschede at princeton.edu)
+!--------------------------------------------------------------------------------------------------
+
+ subroutine model_crustmaps_broadcast(myrank,GC_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+ integer :: myrank
+
+ !model_crustmaps_variables
+ type model_crustmaps_variables
+ sequence
+ double precision, dimension(180*CRUSTMAP_RESOLUTION,&
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
+
+ double precision thicknessnp(NLAYERS_CRUSTMAP)
+ double precision densitynp(NLAYERS_CRUSTMAP)
+ double precision velocpnp(NLAYERS_CRUSTMAP)
+ double precision velocsnp(NLAYERS_CRUSTMAP)
+ double precision thicknesssp(NLAYERS_CRUSTMAP)
+ double precision densitysp(NLAYERS_CRUSTMAP)
+ double precision velocpsp(NLAYERS_CRUSTMAP)
+ double precision velocssp(NLAYERS_CRUSTMAP)
+
+ end type model_crustmaps_variables
+ type (model_crustmaps_variables) GC_V
+ !model_crustmaps_variables
+
+ ! local parameters
+ integer :: ier
+
+ ! master reads in crust maps
+ if(myrank == 0) &
+ call read_general_crustmap(GC_V)
+
+ ! broadcasts values to all processes
+ call MPI_BCAST(GC_V%thickness,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%velocp,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%velocs,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%density,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ ! north pole
+ call MPI_BCAST(GC_V%thicknessnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%densitynp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%velocpnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%velocsnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%densitynp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ ! south pole
+ call MPI_BCAST(GC_V%thicknesssp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%densitysp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%velocpsp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%velocssp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(GC_V%densitysp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+
+ end subroutine model_crustmaps_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! read general crustmap by Matthias Meschede
+
+ subroutine read_general_crustmap(GC_V)
+
+ implicit none
+ include "constants.h"
+
+!Matthias Meschede
+ !model_crustmaps_variables
+ type model_crustmaps_variables
+ sequence
+ double precision, dimension(180*CRUSTMAP_RESOLUTION,&
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
+
+ double precision thicknessnp(NLAYERS_CRUSTMAP)
+ double precision densitynp(NLAYERS_CRUSTMAP)
+ double precision velocpnp(NLAYERS_CRUSTMAP)
+ double precision velocsnp(NLAYERS_CRUSTMAP)
+ double precision thicknesssp(NLAYERS_CRUSTMAP)
+ double precision densitysp(NLAYERS_CRUSTMAP)
+ double precision velocpsp(NLAYERS_CRUSTMAP)
+ double precision velocssp(NLAYERS_CRUSTMAP)
+
+ end type model_crustmaps_variables
+ type (model_crustmaps_variables) GC_V
+ !model_crustmaps_variables
+
+
+
+ integer ila,iln,i,l
+
+ character(len=150) eucrustt3,eucrustt4,eucrustt5,eucrustt6,eucrustt7,&
+ eucrustr3,eucrustr4,eucrustr5,eucrustr6,eucrustr7,&
+ eucrustp3,eucrustp4,eucrustp5,eucrustp6,eucrustp7,&
+ eucrusts3,eucrusts4,eucrusts5,eucrusts6,eucrusts7
+
+!Matthias Meschede
+ call get_value_string(eucrustt3, 'model.eucrustt3','DATA/crustmap/eucrustt3.cmap')
+ call get_value_string(eucrustt4, 'model.eucrustt4','DATA/crustmap/eucrustt4.cmap')
+ call get_value_string(eucrustt5, 'model.eucrustt5','DATA/crustmap/eucrustt5.cmap')
+ call get_value_string(eucrustt6, 'model.eucrustt6','DATA/crustmap/eucrustt6.cmap')
+ call get_value_string(eucrustt7, 'model.eucrustt7','DATA/crustmap/eucrustt7.cmap')
+
+ call get_value_string(eucrustr3, 'model.eucrustr3','DATA/crustmap/eucrustr3.cmap')
+ call get_value_string(eucrustr4, 'model.eucrustr4','DATA/crustmap/eucrustr4.cmap')
+ call get_value_string(eucrustr5, 'model.eucrustr5','DATA/crustmap/eucrustr5.cmap')
+ call get_value_string(eucrustr6, 'model.eucrustr6','DATA/crustmap/eucrustr6.cmap')
+ call get_value_string(eucrustr7, 'model.eucrustr7','DATA/crustmap/eucrustr7.cmap')
+
+ call get_value_string(eucrustp3, 'model.eucrustp3','DATA/crustmap/eucrustp3.cmap')
+ call get_value_string(eucrustp4, 'model.eucrustp4','DATA/crustmap/eucrustp4.cmap')
+ call get_value_string(eucrustp5, 'model.eucrustp5','DATA/crustmap/eucrustp5.cmap')
+ call get_value_string(eucrustp6, 'model.eucrustp6','DATA/crustmap/eucrustp6.cmap')
+ call get_value_string(eucrustp7, 'model.eucrustp7','DATA/crustmap/eucrustp7.cmap')
+
+ call get_value_string(eucrusts3, 'model.eucrusts3','DATA/crustmap/eucrusts3.cmap')
+ call get_value_string(eucrusts4, 'model.eucrusts4','DATA/crustmap/eucrusts4.cmap')
+ call get_value_string(eucrusts5, 'model.eucrusts5','DATA/crustmap/eucrusts5.cmap')
+ call get_value_string(eucrusts6, 'model.eucrusts6','DATA/crustmap/eucrusts6.cmap')
+ call get_value_string(eucrusts7, 'model.eucrusts7','DATA/crustmap/eucrusts7.cmap')
+
+
+
+ open(unit=1,file=eucrustt3,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%thickness(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustt4,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%thickness(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustt5,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%thickness(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustt6,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%thickness(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustt7,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%thickness(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+
+
+ open(unit=1,file=eucrustr3,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%density(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustr4,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%density(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustr5,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%density(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustr6,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%density(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustr7,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%density(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+
+
+ open(unit=1,file=eucrustp3,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%velocp(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustp4,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%velocp(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustp5,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%velocp(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustp6,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%velocp(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrustp7,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%velocp(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+
+
+ open(unit=1,file=eucrusts3,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%velocs(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrusts4,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%velocs(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrusts5,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%velocs(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrusts6,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%velocs(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ open(unit=1,file=eucrusts7,status='old',action='read')
+ do ila=1,180*CRUSTMAP_RESOLUTION
+ read(1,*) (GC_V%velocs(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
+ enddo
+ close(1)
+
+ GC_V%thicknessnp(:) = 0.0
+ GC_V%thicknesssp(:) = 0.0
+ GC_V%densitynp(:) = 0.0
+ GC_V%densitysp(:) = 0.0
+ GC_V%velocpnp(:) = 0.0
+ GC_V%velocpsp(:) = 0.0
+ GC_V%velocsnp(:) = 0.0
+ GC_V%velocssp(:) = 0.0
+
+ !compute average values for north and southpole
+ do l=1,NLAYERS_CRUSTMAP
+ do i=1,360*CRUSTMAP_RESOLUTION
+ GC_V%thicknessnp(l) = GC_V%thicknessnp(l)+GC_V%thickness(1,i,l)
+ GC_V%thicknesssp(l) = GC_V%thicknesssp(l)+GC_V%thickness(180*CRUSTMAP_RESOLUTION,i,l)
+ GC_V%densitynp(l) = GC_V%densitynp(l)+GC_V%density(1,i,l)
+ GC_V%densitysp(l) = GC_V%densitysp(l)+GC_V%density(180*CRUSTMAP_RESOLUTION,i,l)
+ GC_V%velocpnp(l) = GC_V%velocpnp(l)+GC_V%velocp(1,i,l)
+ GC_V%velocpsp(l) = GC_V%velocpsp(l)+GC_V%velocp(180*CRUSTMAP_RESOLUTION,i,l)
+ GC_V%velocsnp(l) = GC_V%velocsnp(l)+GC_V%velocs(1,i,l)
+ GC_V%velocssp(l) = GC_V%velocssp(l)+GC_V%velocs(180*CRUSTMAP_RESOLUTION,i,l)
+ enddo
+ GC_V%thicknessnp(l) = GC_V%thicknessnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ GC_V%thicknesssp(l) = GC_V%thicknesssp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ GC_V%densitynp(l) = GC_V%densitynp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ GC_V%densitysp(l) = GC_V%densitysp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ GC_V%velocpnp(l) = GC_V%velocpnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ GC_V%velocpsp(l) = GC_V%velocpsp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ GC_V%velocsnp(l) = GC_V%velocsnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ GC_V%velocssp(l) = GC_V%velocssp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+
+! print *,'thicknessnp(',l,')',GC_V%thicknessnp(l)
+ enddo
+
+
+ end subroutine read_general_crustmap
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_crustmaps(lat,lon,x,vp,vs,rho,moho,found_crust,GC_V,elem_in_crust)
+
+! Matthias Meschede
+! read smooth crust2.0 model (0.25 degree resolution) with eucrust
+! based on software routines provided with the crust2.0 model by Bassin et al.
+!
+
+ implicit none
+ include "constants.h"
+
+!Matthias Meschede
+ !model_crustmaps_variables
+ type model_crustmaps_variables
+ sequence
+ double precision, dimension(180*CRUSTMAP_RESOLUTION,&
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
+
+ double precision thicknessnp(NLAYERS_CRUSTMAP)
+ double precision densitynp(NLAYERS_CRUSTMAP)
+ double precision velocpnp(NLAYERS_CRUSTMAP)
+ double precision velocsnp(NLAYERS_CRUSTMAP)
+ double precision thicknesssp(NLAYERS_CRUSTMAP)
+ double precision densitysp(NLAYERS_CRUSTMAP)
+ double precision velocpsp(NLAYERS_CRUSTMAP)
+ double precision velocssp(NLAYERS_CRUSTMAP)
+
+ end type model_crustmaps_variables
+ type (model_crustmaps_variables) GC_V
+ !model_crustmaps_variables
+
+
+ double precision lat,lon,x,vp,vs,rho,moho
+ logical found_crust,elem_in_crust
+ double precision h_sed,h_uc
+ double precision x3,x4,x5,x6,x7,scaleval
+ double precision vps(NLAYERS_CRUSTMAP),vss(NLAYERS_CRUSTMAP),rhos(NLAYERS_CRUSTMAP),thicks(NLAYERS_CRUSTMAP)
+
+ call read_crustmaps(lat,lon,vps,vss,rhos,thicks,GC_V)
+
+ x3 = (R_EARTH-thicks(1)*1000.0d0)/R_EARTH
+ h_sed = thicks(1) + thicks(2)
+ x4 = (R_EARTH-h_sed*1000.0d0)/R_EARTH
+ h_uc = h_sed + thicks(3)
+ x5 = (R_EARTH-h_uc*1000.0d0)/R_EARTH
+ x6 = (R_EARTH-(h_uc+thicks(4))*1000.0d0)/R_EARTH
+ x7 = (R_EARTH-(h_uc+thicks(4)+thicks(5))*1000.0d0)/R_EARTH
+
+ found_crust = .true.
+! if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST &
+! .and. h_sed > MINIMUM_SEDIMENT_THICKNESS) then
+ if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST ) then
+ vp = vps(1)
+ vs = vss(1)
+ rho = rhos(1)
+! else if(x > x4 .and. INCLUDE_SEDIMENTS_CRUST &
+! .and. h_sed > MINIMUM_SEDIMENT_THICKNESS) then
+ else if(x > x4 .and. INCLUDE_SEDIMENTS_CRUST ) then
+ vp = vps(2)
+ vs = vss(2)
+ rho = rhos(2)
+ else if(x > x5) then
+ vp = vps(3)
+ vs = vss(3)
+ rho = rhos(3)
+ else if(x > x6) then
+ vp = vps(4)
+ vs = vss(4)
+ rho = rhos(4)
+ else if(x > x7 .or. elem_in_crust) then
+ vp = vps(5)
+ vs = vss(5)
+ rho = rhos(5)
+ 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(4)+thicks(5))*1000.0d0/R_EARTH
+ else
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+ vp = 20.0*1000.0d0/(R_EARTH*scaleval)
+ vs = 20.0*1000.0d0/(R_EARTH*scaleval)
+ rho = 20.0*1000.0d0/RHOAV
+ endif
+
+ moho = (h_uc+thicks(4)+thicks(5))*1000.0d0/R_EARTH
+
+ end subroutine model_crustmaps
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine read_crustmaps(lat,lon,velp,vels,rhos,thicks,GC_V)
+
+! crustal vp and vs in km/s, layer thickness in km
+
+ implicit none
+ include "constants.h"
+
+
+! argument variables
+ double precision lat,lon
+ double precision rhos(5),thicks(5),velp(5),vels(5)
+!Matthias Meschede
+ !model_crustmaps_variables
+ type model_crustmaps_variables
+ sequence
+ double precision, dimension(180*CRUSTMAP_RESOLUTION,&
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
+ double precision, dimension(180*CRUSTMAP_RESOLUTION, &
+ 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
+
+ double precision thicknessnp(NLAYERS_CRUSTMAP)
+ double precision densitynp(NLAYERS_CRUSTMAP)
+ double precision velocpnp(NLAYERS_CRUSTMAP)
+ double precision velocsnp(NLAYERS_CRUSTMAP)
+ double precision thicknesssp(NLAYERS_CRUSTMAP)
+ double precision densitysp(NLAYERS_CRUSTMAP)
+ double precision velocpsp(NLAYERS_CRUSTMAP)
+ double precision velocssp(NLAYERS_CRUSTMAP)
+
+ end type model_crustmaps_variables
+ type (model_crustmaps_variables) GC_V
+ !model_crustmaps_variables
+
+ !-------------------------------
+ ! work-around to avoid jacobian problems when stretching mesh elements;
+ ! one could also try to slightly change the shape of the doulbing element bricks (which cause the problem)...
+ !
+ ! defines a "critical" region to have at least a 1-degree smoothing;
+ ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
+ double precision,parameter :: LAT_CRITICAL_EUROPE = 50.0d0
+ double precision,parameter :: LON_CRITICAL_EUROPE = 22.0d0
+ double precision,parameter :: CRITICAL_RANGE_EUROPE = 50.0d0
+
+ ! defines a "critical" region around the andes to have at least a 1-degree smoothing;
+ ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
+ double precision,parameter :: LAT_CRITICAL_ANDES = -20.0d0
+ double precision,parameter :: LON_CRITICAL_ANDES = -70.0d0
+ double precision,parameter :: CRITICAL_RANGE_ANDES = 70.0d0
+
+ ! sampling rate for CAP points
+ integer, parameter :: NTHETA = 4
+ integer, parameter :: NPHI = 20
+ !-------------------------------
+
+! local variables
+ double precision weightup,weightleft,weightul,weightur,weightll,weightlr
+ double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
+ double precision rhol(NLAYERS_CRUSTMAP),thickl(NLAYERS_CRUSTMAP), &
+ velpl(NLAYERS_CRUSTMAP),velsl(NLAYERS_CRUSTMAP)
+ double precision weightl,cap_degree,dist
+ double precision h_sed
+ integer num_points
+ integer i,ipoin,iupcolat,ileftlng,irightlng
+
+! 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) &
+ write(*,*) lat,' ',lon, ' 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
+
+ ! by defaults uses only 1 point location
+ num_points = 1
+
+ ! checks if inside/outside of critical region for mesh stretching
+ if( SMOOTH_CRUST ) then
+ dist = dsqrt( (lon-LAT_CRITICAL_EUROPE)**2 + (lat-LAT_CRITICAL_EUROPE )**2 )
+ if( dist < CRITICAL_RANGE_EUROPE ) then
+ ! sets up smoothing points
+ ! by default uses CAP smoothing with crustmap resolution, e.g. 1/4 degree
+ cap_degree = 1.d0 / CRUSTMAP_RESOLUTION
+
+ ! increases cap smoothing degree
+ ! scales between -1 at center and 0 at border
+ dist = dist / CRITICAL_RANGE_EUROPE - 1.0d0
+ ! shifts value to 1 at center and 0 to the border with exponential decay
+ dist = 1.0d0 - exp( - dist*dist*10.0d0 )
+ ! increases smoothing degree inside of critical region
+ cap_degree = cap_degree + dist
+
+ ! gets smoothing points and weights
+ call CAP_vardegree(lon,lat,xlon,xlat,weight,cap_degree,NTHETA,NPHI)
+ num_points = NTHETA*NPHI
+ endif
+ dist = dsqrt( (lon-LON_CRITICAL_ANDES)**2 + (lat-LAT_CRITICAL_ANDES )**2 )
+ if( dist < CRITICAL_RANGE_ANDES ) then
+ ! sets up smoothing points
+ ! by default uses CAP smoothing with crustmap resolution, e.g. 1/4 degree
+ cap_degree = 1.d0 / CRUSTMAP_RESOLUTION
+
+ ! increases cap smoothing degree
+ ! scales between -1 at center and 0 at border
+ dist = dist / CRITICAL_RANGE_ANDES - 1.0d0
+ ! shifts value to 1 at center and 0 to the border with exponential decay
+ dist = 1.0d0 - exp( - dist*dist*10.0d0 )
+ ! increases smoothing degree inside of critical region
+ cap_degree = cap_degree + dist
+
+ ! gets smoothing points and weights
+ call CAP_vardegree(lon,lat,xlon,xlat,weight,cap_degree,NTHETA,NPHI)
+ num_points = NTHETA*NPHI
+ endif
+ endif
+
+ ! initializes
+ velp(:) = 0.0d0
+ vels(:) = 0.0d0
+ rhos(:) = 0.0d0
+ thicks(:) = 0.0d0
+
+ ! loops over weight points
+ do ipoin=1,num_points
+ ! checks if more than one weighting points are taken
+ if( num_points > 1 ) then
+ lat = xlat(ipoin)
+ lon = xlon(ipoin)
+ ! weighting value
+ weightl = weight(ipoin)
+ else
+ weightl = 1.0d0
+ endif
+
+ ! gets crust value indices
+ call ibilinearmap(lat,lon,iupcolat,ileftlng,weightup,weightleft)
+
+ ! interpolates location and crust values
+ if(iupcolat==0) then
+ weightup=weightup*2
+ else if(iupcolat==180*CRUSTMAP_RESOLUTION) then
+ weightup=2*weightup-1
+ endif
+
+ if(ileftlng==360*CRUSTMAP_RESOLUTION) then
+ irightlng=1
+ else
+ irightlng=ileftlng+1
+ endif
+
+ weightul=weightup*weightleft
+ weightur=weightup*(1.0-weightleft)
+ weightll=(1.0-weightup)*weightleft
+ weightlr=(1.0-weightup)*(1.0-weightleft)
+
+ if(iupcolat==0) then
+ ! north pole
+ do i=1,NLAYERS_CRUSTMAP
+ thickl(i)=weightul*GC_V%thicknessnp(i)+weightur*GC_V%thicknessnp(i)+&
+ weightll*GC_V%thickness(1,ileftlng,i)+weightlr*GC_V%thickness(1,irightlng,i)
+
+ rhol(i)=weightul*GC_V%densitynp(i)+weightur*GC_V%densitynp(i)+&
+ weightll*GC_V%density(1,ileftlng,i)+weightlr*GC_V%density(1,irightlng,i)
+ velpl(i)=weightul*GC_V%velocpnp(i)+weightur*GC_V%velocpnp(i)+&
+ weightll*GC_V%velocp(1,ileftlng,i)+weightlr*GC_V%velocp(1,irightlng,i)
+ velsl(i)=weightul*GC_V%velocsnp(i)+weightur*GC_V%velocsnp(i)+&
+ weightll*GC_V%velocs(1,ileftlng,i)+weightlr*GC_V%velocs(1,irightlng,i)
+ enddo
+ elseif(iupcolat==180*CRUSTMAP_RESOLUTION) then
+ ! south pole
+ do i=1,NLAYERS_CRUSTMAP
+ thickl(i)=weightul*GC_V%thickness(iupcolat,ileftlng,i)+weightur*GC_V%thickness(iupcolat,irightlng,i)+&
+ weightll*GC_V%thicknesssp(i)+weightlr*GC_V%thicknesssp(i)
+ rhol(i)=weightul*GC_V%density(iupcolat,ileftlng,i)+weightur*GC_V%density(iupcolat,irightlng,i)+&
+ weightll*GC_V%densitysp(i)+weightlr*GC_V%densitysp(i)
+ velpl(i)=weightul*GC_V%velocp(iupcolat,ileftlng,i)+weightur*GC_V%velocp(iupcolat,irightlng,i)+&
+ weightll*GC_V%velocpsp(i)+weightlr*GC_V%velocpsp(i)
+ velsl(i)=weightul*GC_V%velocs(iupcolat,ileftlng,i)+weightur*GC_V%velocs(iupcolat,irightlng,i)+&
+ weightll*GC_V%velocssp(i)+weightlr*GC_V%velocssp(i)
+ enddo
+ else
+ do i=1,NLAYERS_CRUSTMAP
+ thickl(i)=weightul*GC_V%thickness(iupcolat,ileftlng,i)+weightur*GC_V%thickness(iupcolat,irightlng,i)+&
+ weightll*GC_V%thickness(iupcolat+1,ileftlng,i)+weightlr*GC_V%thickness(iupcolat+1,irightlng,i)
+ rhol(i)=weightul*GC_V%density(iupcolat,ileftlng,i)+weightur*GC_V%density(iupcolat,irightlng,i)+&
+ weightll*GC_V%density(iupcolat+1,ileftlng,i)+weightlr*GC_V%density(iupcolat+1,irightlng,i)
+ velpl(i)=weightul*GC_V%velocp(iupcolat,ileftlng,i)+weightur*GC_V%velocp(iupcolat,irightlng,i)+&
+ weightll*GC_V%velocp(iupcolat+1,ileftlng,i)+weightlr*GC_V%velocp(iupcolat+1,irightlng,i)
+ velsl(i)=weightul*GC_V%velocs(iupcolat,ileftlng,i)+weightur*GC_V%velocs(iupcolat,irightlng,i)+&
+ weightll*GC_V%velocs(iupcolat+1,ileftlng,i)+weightlr*GC_V%velocs(iupcolat+1,irightlng,i)
+ ! thicks(i)=1.0
+ ! rhos(i)=1.0
+ ! velp(i)=1.0
+ ! vels(i)=1.0i
+ enddo
+ endif
+
+ ! sediment thickness
+ h_sed = thickl(1) + thickl(2)
+
+ ! takes upper crust value if sediment too thin
+ if( h_sed < MINIMUM_SEDIMENT_THICKNESS ) then
+ velpl(1) = velpl(3)
+ velpl(2) = velpl(3)
+ velsl(1) = velsl(3)
+ velsl(2) = velsl(3)
+ rhol(1) = rhol(3)
+ rhol(2) = rhol(3)
+ endif
+
+ ! total, smoothed values
+ rhos(:) = rhos(:) + weightl*rhol(:)
+ thicks(:) = thicks(:) + weightl*thickl(:)
+ velp(:) = velp(:) + weightl*velpl(:)
+ vels(:) = vels(:) + weightl*velsl(:)
+ enddo
+
+ end subroutine read_crustmaps
+
+!--------------------------------------------------------------------------------------------
+
+ subroutine ibilinearmap(lat,lng,iupcolat,ileftlng,weightup,weightleft)
+
+ implicit none
+ include "constants.h"
+
+
+! argument variables
+ double precision weightup,weightleft
+ double precision lat,lng, xlng
+ double precision buffer
+ integer iupcolat
+ integer ileftlng
+
+ if(lat > 90.0d0 .or. lat < -90.0d0 .or. lng > 180.0d0 .or. lng < -180.0d0) &
+ stop 'error in latitude/longitude range in icolat_ilon'
+
+ if(lng<0) then
+ xlng=lng+360.0
+ else
+ xlng=lng
+ endif
+
+ buffer=0.5+((90.0-lat)*CRUSTMAP_RESOLUTION)
+ iupcolat=int(buffer)
+ weightup=1.0-(buffer-dble(iupcolat))
+
+ if(iupcolat<0) iupcolat=0
+ if(iupcolat>180*CRUSTMAP_RESOLUTION) iupcolat=180*CRUSTMAP_RESOLUTION
+
+
+ buffer=0.5+(xlng*CRUSTMAP_RESOLUTION)
+ ileftlng=int(buffer)
+ weightleft=1.0-(buffer-dble(ileftlng))
+
+ if(ileftlng<1) ileftlng=360*CRUSTMAP_RESOLUTION
+ if(ileftlng>360*CRUSTMAP_RESOLUTION) ileftlng=1
+
+
+
+ end subroutine ibilinearmap
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+!
+! subroutine ilatlng(lat,lng,icolat,ilng)
+!
+! implicit none
+! include "constants.h"
+!
+!
+! ! argument variables
+! double precision lat,lng, xlng
+! integer icolat,ilng
+!
+! if(lat > 90.0d0 .or. lat < -90.0d0 .or. lng > 180.0d0 .or. lng < -180.0d0) &
+! stop 'error in latitude/longitude range in icolat_ilon'
+!
+! if(lng<0) then
+! xlng=lng+360.0
+! else
+! xlng=lng
+! endif
+!
+! icolat=int(1+((90.0-lat)*CRUSTMAP_RESOLUTION))
+! ! icolat=10
+! if(icolat == 180*CRUSTMAP_RESOLUTION+1) icolat=180*CRUSTMAP_RESOLUTION
+! ilng=int(1+(xlng*CRUSTMAP_RESOLUTION))
+! ! ilng=10
+! if(ilng == 360*CRUSTMAP_RESOLUTION+1) ilng=360*CRUSTMAP_RESOLUTION
+!
+! if(icolat>180*CRUSTMAP_RESOLUTION .or. icolat<1) stop 'error in routine icolat_ilon'
+! if(ilng<1 .or. ilng>360*CRUSTMAP_RESOLUTION) stop 'error in routine icolat_ilon'
+!
+! end subroutine ilatlng
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_eucrust.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_eucrust.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_eucrust.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_eucrust.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,429 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! EUCRUST-07
+!
+! Tesauro, M., M. K. Kaban and S. A. P. L. Cloetingh, 2008.
+! Eucrust-07: A New Reference Model for the European Crust,
+! Geophysical Research Letters, 35: p. L05313.208
+!--------------------------------------------------------------------------------------------------
+
+ subroutine model_eucrust_broadcast(myrank,EUCM_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+ ! EUcrust
+ type model_eucrust_variables
+ sequence
+ double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
+ eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
+ eucrust_basement,eucrust_ucdepth
+ integer :: num_eucrust
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_eucrust_variables
+ type (model_eucrust_variables) EUCM_V
+
+ integer :: myrank
+ integer :: ier
+
+ ! EUcrust07 Vp crustal structure
+ if( myrank == 0 ) call read_EuCrust(EUCM_V)
+
+ ! broadcast the information read on the master to the nodes
+ call MPI_BCAST(EUCM_V%num_eucrust,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ if( myrank /= 0 ) then
+ allocate(EUCM_V%eucrust_vp_uppercrust(EUCM_V%num_eucrust),EUCM_V%eucrust_vp_lowercrust(EUCM_V%num_eucrust),&
+ EUCM_V%eucrust_mohodepth(EUCM_V%num_eucrust),EUCM_V%eucrust_basement(EUCM_V%num_eucrust),&
+ EUCM_V%eucrust_ucdepth(EUCM_V%num_eucrust), EUCM_V%eucrust_lon(EUCM_V%num_eucrust),&
+ EUCM_V%eucrust_lat(EUCM_V%num_eucrust))
+ endif
+
+ call MPI_BCAST(EUCM_V%eucrust_lat(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(EUCM_V%eucrust_lon(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(EUCM_V%eucrust_vp_uppercrust(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(EUCM_V%eucrust_vp_lowercrust(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(EUCM_V%eucrust_mohodepth(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(EUCM_V%eucrust_basement(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(EUCM_V%eucrust_ucdepth(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ end subroutine model_eucrust_broadcast
+
+!----------------------------------------------------------------------------------------------------
+
+ subroutine read_EuCrust(EUCM_V)
+
+ implicit none
+
+ include "constants.h"
+
+ type model_eucrust_variables
+ sequence
+ double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
+ eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
+ eucrust_basement,eucrust_ucdepth
+ integer :: num_eucrust
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_eucrust_variables
+ type (model_eucrust_variables) EUCM_V
+
+
+ ! local variables
+ character(len=80):: line
+ character(len=150):: filename
+ integer:: i,ierror
+ double precision:: vp_uppercrust,vp_lowercrust,vp_avg,topo,basement
+ double precision:: upper_lower_depth,moho_depth,lat,lon
+
+ ! original file size entries
+ EUCM_V%num_eucrust = 36058
+
+ allocate(EUCM_V%eucrust_vp_uppercrust(EUCM_V%num_eucrust),EUCM_V%eucrust_vp_lowercrust(EUCM_V%num_eucrust),&
+ EUCM_V%eucrust_mohodepth(EUCM_V%num_eucrust),EUCM_V%eucrust_basement(EUCM_V%num_eucrust),&
+ EUCM_V%eucrust_ucdepth(EUCM_V%num_eucrust), EUCM_V%eucrust_lon(EUCM_V%num_eucrust),&
+ EUCM_V%eucrust_lat(EUCM_V%num_eucrust))
+
+ EUCM_V%eucrust_vp_uppercrust(:) = 0.0
+ EUCM_V%eucrust_vp_lowercrust(:) = 0.0
+ EUCM_V%eucrust_mohodepth(:) = 0.0
+ EUCM_V%eucrust_basement(:) = 0.0
+ EUCM_V%eucrust_ucdepth(:) = 0.0
+
+ ! opens data file
+ call get_value_string(filename, 'model.eu', 'DATA/eucrust-07/ds01.txt')
+ open(unit=11,file=filename,status='old',action='read')
+
+ ! skip first line
+ read(11,*)
+
+ ! data
+ do i=1,36058
+
+ read(11,'(a80)',iostat=ierror) line
+ if(ierror .ne. 0 ) stop
+
+ read(line,*)lon,lat,vp_uppercrust,vp_lowercrust,vp_avg,topo,basement,upper_lower_depth,moho_depth
+
+ ! stores moho values
+ EUCM_V%eucrust_lon(i) = lon
+ EUCM_V%eucrust_lat(i) = lat
+ EUCM_V%eucrust_vp_uppercrust(i) = vp_uppercrust
+ EUCM_V%eucrust_vp_lowercrust(i) = vp_lowercrust
+ EUCM_V%eucrust_mohodepth(i) = moho_depth
+ EUCM_V%eucrust_basement(i) = basement
+ EUCM_V%eucrust_ucdepth(i) = upper_lower_depth
+
+ enddo
+ close(11)
+
+ end subroutine read_EuCrust
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_eucrust(lat,lon,x,vp,found_crust,EUCM_V)
+
+ implicit none
+
+ type model_eucrust_variables
+ sequence
+ double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
+ eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
+ eucrust_basement,eucrust_ucdepth
+ integer :: num_eucrust
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_eucrust_variables
+ type (model_eucrust_variables) EUCM_V
+
+ double precision :: lat,lon,x,vp
+ logical :: found_crust
+ double precision :: lon_min,lon_max,lat_min,lat_max
+ double precision, external:: crust_eu
+
+ ! initializes
+ vp = 0.d0
+
+ ! eucrust boundary region
+ lon_min = -24.875
+ lon_max = 35.375
+
+ lat_min = 34.375
+ lat_max = 71.375
+
+ found_crust = .false.
+ if( lon < lon_min .or. lon > lon_max ) return
+ if( lat < lat_min .or. lat > lat_max ) return
+
+ ! smoothing over 1.0 degrees
+ call eu_cap_smoothing(lat,lon,x,vp,found_crust,EUCM_V)
+
+ ! without smoothing
+ !vp = crust_eu(lat,lon,x,vp,found_crust,EUCM_V)
+
+ end subroutine model_eucrust
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ double precision function crust_eu(lat,lon,x,vp,found_crust,EUCM_V)
+
+! returns Vp at the specific location lat/lon
+
+ implicit none
+
+ include "constants.h"
+
+ type model_eucrust_variables
+ sequence
+ double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
+ eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
+ eucrust_basement,eucrust_ucdepth
+ integer :: num_eucrust
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_eucrust_variables
+ type (model_eucrust_variables) EUCM_V
+
+ double precision :: lat,lon,x,vp !,vs,rho,moho
+ logical :: found_crust
+
+ double precision :: longitude_min,longitude_max,latitude_min,latitude_max
+ double precision :: h_basement,h_uc,h_moho,x3,x4,x5
+ double precision :: scaleval
+
+ integer :: i,j
+ integer,parameter :: ilons = 242 ! number of different longitudes
+ integer,parameter :: ilats = 149 ! number of different latitudes
+
+ ! eucrust boundary region
+ longitude_min = -24.875
+ longitude_max = 35.375
+
+ latitude_min = 34.375
+ latitude_max = 71.375
+
+ found_crust = .false.
+ crust_eu = 0.0
+ if( lon < longitude_min .or. lon > longitude_max ) return
+ if( lat < latitude_min .or. lat > latitude_max ) return
+
+ ! search
+ do i=1,ilons-1
+ if( lon >= EUCM_V%eucrust_lon(i) .and. lon < EUCM_V%eucrust_lon(i+1) ) then
+ do j=0,ilats-1
+ if(lat>=EUCM_V%eucrust_lat(i+j*ilons) .and. lat<EUCM_V%eucrust_lat(i+(j+1)*ilons)) then
+
+ h_basement = EUCM_V%eucrust_basement(i+j*ilons)
+ h_uc = EUCM_V%eucrust_ucdepth(i+j*ilons)
+ h_moho = EUCM_V%eucrust_mohodepth(i+j*ilons)
+
+ x3=(R_EARTH - h_basement*1000.0d0)/R_EARTH
+ x4=(R_EARTH - h_uc*1000.0d0)/R_EARTH
+ x5=(R_EARTH - h_moho*1000.0d0)/R_EARTH
+
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+
+ if( x > x3 .and. INCLUDE_SEDIMENTS_CRUST &
+ .and. h_basement > MINIMUM_SEDIMENT_THICKNESS) then
+ ! above sediment basement, returns average upper crust value
+ ! since no special sediment values are given
+ found_crust = .true.
+ vp = EUCM_V%eucrust_vp_uppercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
+ crust_eu = vp
+ return
+ else if( x > x4 ) then
+ found_crust = .true.
+ vp = EUCM_V%eucrust_vp_uppercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
+ crust_eu = vp
+ return
+ else if( x > x5 ) then
+ found_crust = .true.
+ vp = EUCM_V%eucrust_vp_lowercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
+ crust_eu = vp
+ return
+ endif
+ return
+ endif
+ enddo
+ endif
+ enddo
+
+ end function crust_eu
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+ subroutine eu_cap_smoothing(lat,lon,radius,value,found,EUCM_V)
+
+! smooths with a cap of size CAP (in degrees)
+! using NTHETA points in the theta direction (latitudal)
+! and NPHI in the phi direction (longitudal).
+! The cap is rotated to the North Pole.
+
+ implicit none
+ include "constants.h"
+
+ ! argument variables
+ double precision lat,lon,radius
+ double precision :: value
+ logical :: found
+
+ type model_eucrust_variables
+ sequence
+ double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
+ eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
+ eucrust_basement,eucrust_ucdepth
+ integer :: num_eucrust
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_eucrust_variables
+ type (model_eucrust_variables) EUCM_V
+
+ integer, parameter :: NTHETA = 4
+ integer, parameter :: NPHI = 10
+ double precision, parameter :: CAP = 1.0d0*PI/180.0d0 ! 1 degree smoothing
+
+ double precision,external :: crust_eu
+
+ ! 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,valuel
+ 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)
+
+ ! 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 as is, without smoothing
+ ! value = func(lat,lon,x,value,found,EUCM_V)
+ ! 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
+
+ ! at this point:
+ !
+ ! xlat(i),xlon(i) are point locations to be used for interpolation
+ ! with weights weight(i)
+
+ ! integrates value
+ value = 0.0d0
+ do i=1,npoints
+ valuel = crust_eu(xlat(i),xlon(i),radius,value,found,EUCM_V)
+ value = value + weight(i)*valuel
+ enddo
+
+ if( abs(value) < TINYVAL) found = .false.
+
+ end subroutine eu_cap_smoothing
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_gapp2.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_gapp2.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_gapp2.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_gapp2.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+!
+! GAP P2 model - Global automatic parameterization model
+!
+! 3D Vp mantle model (version P2) from Masayuki Obayashi
+!
+!--------------------------------------------------------------------------------------------------
+
+
+ module gapp2_mantle_model_constants
+ ! data file resolution
+ integer, parameter :: ma=228,mo=576,mr=32,mr1=64
+ integer no,na,nnr,nr1
+ real dela,delo
+ ! allocatable model arrays
+ real,dimension(:),allocatable :: dep,dep1,vp1
+ real,dimension(:,:,:),allocatable :: vp3
+ end module gapp2_mantle_model_constants
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_gapp2_broadcast(myrank)
+
+! standard routine to setup model
+
+ use gapp2_mantle_model_constants
+
+ implicit none
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+ integer :: myrank
+ integer :: ier
+
+ ! allocates arrays only when called and needed
+ allocate(dep(0:mr),dep1(0:mr1),vp1(0:mr1),vp3(ma,mo,mr), &
+ stat=ier)
+ if( ier /= 0 ) then
+ call exit_mpi(myrank,'error allocation GAP model')
+ endif
+
+ ! the variables read are declared in the module
+ if(myrank == 0) call read_mantle_gapmodel()
+
+ ! master process broadcasts data to all processes
+ call MPI_BCAST( dep,mr+1,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(dep1,mr1+1,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST( vp1,mr1+1,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST( vp3,ma*mo*mr,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST( nnr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST( nr1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST( no,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST( na,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST( dela,1,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST( delo,1,MPI_REAL,0,MPI_COMM_WORLD,ier)
+
+ end subroutine model_gapp2_broadcast
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_mantle_gapmodel()
+
+ use gapp2_mantle_model_constants
+
+ implicit none
+ include "constants.h"
+ integer i,ir,ia,io
+ character(len=150) GAPP2
+
+!...........................................input data
+
+ ! default model: 3dvpGAP_P2
+ call get_value_string(GAPP2, 'model.GAPP2', 'DATA/3dvpGAP_P2')
+
+ ! reads in GAP-P2 model from Obayashi
+ open(unit=10,file=GAPP2,status='old',action='read')
+
+ read(10,'(3i4,2f10.6)') no,na,nnr,dela,delo
+ read(10,'(34f8.2)') (dep(i),i=0,nnr)
+ read(10,*) nr1
+ read(10,'(67f8.2)') (dep1(i),i=0,nr1)
+ read(10,'(67f8.3)') (vp1(i),i=0,nr1)
+ do ir=1,nnr
+ do ia=1,na
+ read(10,'(256f7.3)') (vp3(ia,io,ir),io=1,no)
+ enddo
+ enddo
+ write(6,*) vp3(1,1,1),vp3(na,no,nnr)
+ close(10)
+
+ end subroutine read_mantle_gapmodel
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine mantle_gapmodel(radius,theta,phi,dvs,dvp,drho)
+
+ use gapp2_mantle_model_constants
+
+ implicit none
+ include "constants.h"
+ integer id,ia,io,icon
+ real d,dtheta,dphi
+
+ double precision radius,theta,phi,dvs,dvp,drho
+
+! factor to convert perturbations in shear speed to perturbations in density
+ double precision, parameter :: SCALE_VS = 1.40d0
+ double precision, parameter :: SCALE_RHO = 0.0d0
+
+ double precision, parameter :: R_EARTH_ = 6371.d0
+ double precision, parameter :: ZERO_ = 0.d0
+
+!.....................................
+
+ dvs = ZERO_
+ dvp = ZERO_
+ drho = ZERO_
+
+ ! increments in latitude/longitude (in rad)
+ dtheta = dela * PI / 180.0
+ dphi = delo * PI / 180.0
+
+ ! depth given in km
+ d=R_EARTH_-radius*R_EARTH_
+
+ call d2id(d,nnr,dep,id,icon)
+ if(icon.ne.0) then
+ write(6,*)icon
+ write(6,*) radius,theta,phi,dvp,dvs,drho
+ endif
+
+ ! latitude
+ if(theta.ge.PI) then
+ ia = na
+ else
+ ia = theta / dtheta + 1
+ endif
+ ! longitude
+ if(phi .lt. 0.0d0) phi = phi + 2.*PI
+ io=phi / dphi + 1
+ if(io.gt.no) io=io-no
+
+ ! velocity and density perturbations
+ dvp = vp3(ia,io,id)/100.d0
+ dvs = SCALE_VS*dvp
+ drho = SCALE_RHO*dvs
+
+ end subroutine mantle_gapmodel
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine d2id(d,mr,di,id,icon)
+!.................................................................
+! radial section index for a given depth d
+!.................................................................
+! d i depth(km)
+! mr i number of radial division
+! di i depth table
+! id o depth section index for d
+! shallow .... di(id-1) <= d < di(id) .... deep
+! icon o condition code
+! 0:normal, -99:above the surface, 99:below the cmb
+!.................................................................
+ integer i, mr, id, icon
+ real d,dmax,dmin
+ real di(0:mr)
+ icon=0
+ dmax=di(mr)
+ dmin=di(0)
+ if(d.gt.dmax) then
+ icon=99
+ else if(d.lt.dmin) then
+ icon=-99
+ else if(d.eq.dmax) then
+ id=mr+1
+ else
+ do i = 0, mr
+ if(d.lt.di(i)) then
+ id=i
+ goto 900
+ endif
+ enddo
+ end if
+900 continue
+
+!..................................................................
+ return
+
+ end subroutine d2id
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_gll.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_gll.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_gll.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_gll.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,345 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! GLL
+!
+! based on modified GLL mesh output from mesher
+!
+! used for iterative inversion procedures
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_gll_broadcast(myrank,MGLL_V,NSPEC)
+
+! standard routine to setup model
+
+ use meshfem3D_models_par,only: TRANSVERSE_ISOTROPY
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+ include "precision.h"
+
+ ! GLL model_variables
+ type model_gll_variables
+ sequence
+ ! tomographic iteration model on GLL points
+ double precision :: scale_velocity,scale_density
+ ! isotropic model
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vs_new,vp_new,rho_new
+ ! transverse isotropic model
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vsv_new,vpv_new, &
+ vsh_new,vph_new,eta_new
+ logical :: MODEL_GLL
+ logical,dimension(3) :: dummy_pad ! padding 3 bytes to align the structure
+ end type model_gll_variables
+ type (model_gll_variables) MGLL_V
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC
+ integer :: myrank
+
+ ! local parameters
+ double precision :: scaleval
+ real(kind=CUSTOM_REAL) :: min,max,min_all,max_all
+ integer :: ier
+
+ ! allocates arrays
+ ! differs for isotropic model or transverse isotropic models
+ if( .not. TRANSVERSE_ISOTROPY ) then
+ ! isotropic model
+ allocate( MGLL_V%vp_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
+ allocate( MGLL_V%vs_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
+ else
+ ! transverse isotropic model
+ allocate( MGLL_V%vpv_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
+ allocate( MGLL_V%vph_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
+ allocate( MGLL_V%vsv_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
+ allocate( MGLL_V%vsh_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
+ allocate( MGLL_V%eta_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
+ endif
+ allocate( MGLL_V%rho_new(NGLLX,NGLLY,NGLLZ,NSPEC(IREGION_CRUST_MANTLE)) )
+
+ ! reads in model files for each process
+ call read_gll_model(myrank,MGLL_V,NSPEC)
+
+ ! checks velocity range
+ if( .not. TRANSVERSE_ISOTROPY ) then
+
+ ! isotropic model
+ if( myrank == 0 ) then
+ write(IMAIN,*)'model GLL: isotropic'
+ endif
+
+ ! Vs
+ max = maxval( MGLL_V%vs_new )
+ min = minval( MGLL_V%vs_new )
+ call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+ call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' vs new min/max: ',min_all,max_all
+ endif
+ ! Vp
+ max = maxval( MGLL_V%vp_new )
+ min = minval( MGLL_V%vp_new )
+ call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+ call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' vp new min/max: ',min_all,max_all
+ endif
+ ! density
+ max = maxval( MGLL_V%rho_new )
+ min = minval( MGLL_V%rho_new )
+ call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+ call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' rho new min/max: ',min_all,max_all
+ write(IMAIN,*)
+ endif
+
+ else
+
+ ! transverse isotropic model
+ if( myrank == 0 ) then
+ write(IMAIN,*)'model GLL: transverse isotropic'
+ endif
+
+ ! Vsv
+ max = maxval( MGLL_V%vsv_new )
+ min = minval( MGLL_V%vsv_new )
+ call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+ call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' vsv new min/max: ',min_all,max_all
+ endif
+ ! Vsh
+ max = maxval( MGLL_V%vsh_new )
+ min = minval( MGLL_V%vsh_new )
+ call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+ call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' vsh new min/max: ',min_all,max_all
+ endif
+ ! Vpv
+ max = maxval( MGLL_V%vpv_new )
+ min = minval( MGLL_V%vpv_new )
+ call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+ call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' vpv new min/max: ',min_all,max_all
+ endif
+ ! Vph
+ max = maxval( MGLL_V%vph_new )
+ min = minval( MGLL_V%vph_new )
+ call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+ call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' vph new min/max: ',min_all,max_all
+ endif
+ ! density
+ max = maxval( MGLL_V%rho_new )
+ min = minval( MGLL_V%rho_new )
+ call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+ call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' rho new min/max: ',min_all,max_all
+ endif
+ ! eta
+ max = maxval( MGLL_V%eta_new )
+ min = minval( MGLL_V%eta_new )
+ call mpi_reduce(max, max_all, 1, CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+ call mpi_reduce(min, min_all, 1, CUSTOM_MPI_TYPE, MPI_MIN, 0, MPI_COMM_WORLD,ier)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' eta new min/max: ',min_all,max_all
+ write(IMAIN,*)
+ endif
+
+ endif
+
+ ! non-dimensionalizes model values
+ ! (SPECFEM3D_GLOBE uses non-dimensionalized values in subsequent computations)
+ ! scaling values
+ ! (model velocities must be given as km/s)
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+ MGLL_V%scale_velocity = 1000.0d0/(R_EARTH*scaleval)
+ MGLL_V%scale_density = 1000.0d0/RHOAV
+ if( .not. TRANSVERSE_ISOTROPY ) then
+ ! non-dimensionalize isotropic values
+ MGLL_V%vp_new = MGLL_V%vp_new * MGLL_V%scale_velocity
+ MGLL_V%vs_new = MGLL_V%vs_new * MGLL_V%scale_velocity
+ MGLL_V%rho_new = MGLL_V%rho_new * MGLL_V%scale_density
+ else
+ ! non-dimensionalize
+ ! transverse isotropic model
+ MGLL_V%vpv_new = MGLL_V%vpv_new * MGLL_V%scale_velocity
+ MGLL_V%vph_new = MGLL_V%vph_new * MGLL_V%scale_velocity
+ MGLL_V%vsv_new = MGLL_V%vsv_new * MGLL_V%scale_velocity
+ MGLL_V%vsh_new = MGLL_V%vsh_new * MGLL_V%scale_velocity
+ MGLL_V%rho_new = MGLL_V%rho_new * MGLL_V%scale_density
+ ! eta is already non-dimensional
+ endif
+
+ end subroutine model_gll_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine read_gll_model(myrank,MGLL_V,NSPEC)
+
+ use meshfem3D_models_par,only: TRANSVERSE_ISOTROPY
+
+ implicit none
+
+ include "constants.h"
+
+ ! GLL model_variables
+ type model_gll_variables
+ sequence
+ ! tomographic iteration model on GLL points
+ double precision :: scale_velocity,scale_density
+ ! isotropic model
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vs_new,vp_new,rho_new
+ ! transverse isotropic model
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vsv_new,vpv_new, &
+ vsh_new,vph_new,eta_new
+ logical :: MODEL_GLL
+ logical,dimension(3) :: dummy_pad ! padding 3 bytes to align the structure
+ end type model_gll_variables
+ type (model_gll_variables) MGLL_V
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC
+ integer :: myrank
+
+ !--------------------------------------------------------------------
+ ! USER PARAMETER
+
+ character(len=150),parameter:: MGLL_path = 'DATA/GLL/'
+ !--------------------------------------------------------------------
+
+ ! local parameters
+ integer :: ier
+ character(len=150) :: prname
+
+ if( myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*)'reading in model from ',trim(MGLL_path)
+ endif
+
+ ! only crust and mantle
+ write(prname,'(a,i6.6,a)') MGLL_path(1:len_trim(MGLL_path))//'proc',myrank,'_reg1_'
+
+ ! reads in model for each partition
+ if( .not. TRANSVERSE_ISOTROPY ) then
+ ! isotropic model
+ ! vp mesh
+ open(unit=27,file=prname(1:len_trim(prname))//'vp_new.bin',&
+ status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ write(IMAIN,*) 'error opening: ',prname(1:len_trim(prname))//'vp_new.bin'
+ call exit_MPI(myrank,'error model gll')
+ endif
+ read(27) MGLL_V%vp_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
+ close(27)
+
+ ! vs mesh
+ open(unit=27,file=prname(1:len_trim(prname))//'vs_new.bin', &
+ status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',prname(1:len_trim(prname))//'vs_new.bin'
+ call exit_MPI(myrank,'error model gll')
+ endif
+ read(27) MGLL_V%vs_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
+ close(27)
+
+ else
+
+ ! transverse isotropic model
+ ! vp mesh
+ open(unit=27,file=prname(1:len_trim(prname))//'vpv_new.bin',&
+ status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ write(IMAIN,*) 'error opening: ',prname(1:len_trim(prname))//'vpv_new.bin'
+ call exit_MPI(myrank,'error model gll')
+ endif
+ read(27) MGLL_V%vpv_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
+ close(27)
+
+ open(unit=27,file=prname(1:len_trim(prname))//'vph_new.bin',&
+ status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ write(IMAIN,*) 'error opening: ',prname(1:len_trim(prname))//'vph_new.bin'
+ call exit_MPI(myrank,'error model gll')
+ endif
+ read(27) MGLL_V%vph_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
+ close(27)
+
+ ! vs mesh
+ open(unit=27,file=prname(1:len_trim(prname))//'vsv_new.bin', &
+ status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',prname(1:len_trim(prname))//'vsv_new.bin'
+ call exit_MPI(myrank,'error model gll')
+ endif
+ read(27) MGLL_V%vsv_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
+ close(27)
+
+ open(unit=27,file=prname(1:len_trim(prname))//'vsh_new.bin', &
+ status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',prname(1:len_trim(prname))//'vsh_new.bin'
+ call exit_MPI(myrank,'error model gll')
+ endif
+ read(27) MGLL_V%vsh_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
+ close(27)
+
+ ! eta mesh
+ open(unit=27,file=prname(1:len_trim(prname))//'eta_new.bin', &
+ status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',prname(1:len_trim(prname))//'eta_new.bin'
+ call exit_MPI(myrank,'error model gll')
+ endif
+ read(27) MGLL_V%eta_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
+ close(27)
+
+ endif
+
+ ! rho mesh
+ open(unit=27,file=prname(1:len_trim(prname))//'rho_new.bin', &
+ status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening: ',prname(1:len_trim(prname))//'rho_new.bin'
+ call exit_MPI(myrank,'error model gll')
+ endif
+ read(27) MGLL_V%rho_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
+ close(27)
+
+ end subroutine read_gll_model
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_heterogen_mantle.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_heterogen_mantle.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_heterogen_mantle.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_heterogen_mantle.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,220 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! HMM
+!
+! generic heterogeneous mantle model
+!--------------------------------------------------------------------------------------------------
+
+ subroutine model_heterogen_mntl_broadcast(myrank,HMM)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+ ! model_heterogen_m_variables
+ type model_heterogen_m_variables
+ sequence
+ double precision rho_in(N_R*N_THETA*N_PHI)
+ end type model_heterogen_m_variables
+
+ type (model_heterogen_m_variables) HMM
+ ! model_heterogen_m_variables
+
+ integer :: myrank
+ integer :: ier
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'Reading in model_heterogen_mantle.'
+ call read_heterogen_mantle_model(HMM)
+ write(IMAIN,*) 'model_heterogen_mantle is read in.'
+ endif
+
+ ! broadcast the information read on the master to the nodes
+ call MPI_BCAST(HMM%rho_in,N_R*N_THETA*N_PHI,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'model_heterogen_mantle is broadcast.'
+ write(IMAIN,*) 'First value in HMM:',HMM%rho_in(1)
+ write(IMAIN,*) 'Last value in HMM:',HMM%rho_in(N_R*N_THETA*N_PHI)
+ endif
+
+ end subroutine model_heterogen_mntl_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+!
+! NOTE: CURRENTLY THIS ROUTINE ONLY WORKS FOR N_R=N_THETA=N_PHI !!!!!
+!
+
+ subroutine read_heterogen_mantle_model(HMM)
+
+ implicit none
+
+ include "constants.h"
+
+ integer i,j
+
+! model_heterogen_m_variables
+ type model_heterogen_m_variables
+ sequence
+ double precision rho_in(N_R*N_THETA*N_PHI)
+ end type model_heterogen_m_variables
+
+ type (model_heterogen_m_variables) HMM
+! model_heterogen_m_variables
+
+
+! open heterogen.dat
+ open(unit=10,file='./DATA/heterogen/heterogen.dat',access='direct',&
+ form='formatted',recl=20,status='old',action='read')
+
+ j = N_R*N_THETA*N_PHI
+
+ do i = 1,j
+ read(10,rec=i,fmt='(F20.15)') HMM%rho_in(i)
+ end do
+
+ close(10)
+
+ end subroutine read_heterogen_mantle_model
+
+!====================================================================
+
+ subroutine model_heterogen_mantle(radius,theta,phi,dvs,dvp,drho,HMM)
+
+ implicit none
+
+ include "constants.h"
+
+ ! variable declaration
+ double precision radius,theta,phi ! input coordinates
+ double precision x,y,z ! input converted to cartesian
+ double precision drho,dvp,dvs ! output anomaly values
+ double precision x_low,x_high ! x values used to interpolate
+ double precision y_low,y_high ! y values used to interpolate
+ double precision z_low,z_high ! z values used to interpolate
+ double precision delta,delta2 ! weigts in record# and in interpolation
+ double precision rho1,rho2,rho3,rho4,rho5,rho6,rho7,rho8 ! rho values at the interpolation points
+ double precision r_inner,r_outer ! lower and upper domain bounds for r
+ integer rec_read ! nr of record to be read from heterogen.dat (direct access file)
+ double precision a,b,c ! substitutions in interpolation algorithm (weights)
+
+
+! model_heterogen_m_variables
+ type model_heterogen_m_variables
+ sequence
+ double precision rho_in(N_R*N_THETA*N_PHI)
+ end type model_heterogen_m_variables
+
+ type (model_heterogen_m_variables) HMM
+! model_heterogen_m_variables
+
+ radius = radius*R_EARTH
+ r_inner = 3.500d6 !lower bound for heterogeneity zone
+! NOTE: r_outer NEEDS TO BE (just) SMALLER THAN R_EARTH!!!!!!!!
+ r_outer = R_EARTH-1.0d1 !6.300d6 !upper bound for heterogeneity zone (lower mantle: e.g. 4.500d6)
+
+ delta = 2.*R_EARTH/(real(N_R-1))
+ delta2 = 2.*R_EARTH/(real(N_R-2))
+ !delta2 = 2.*R_EARTH/(real(N_R))
+
+ if ((radius >= r_inner) .and. (radius <= r_outer)) then
+ ! convert spherical point to cartesian point, move origin to corner
+ x = R_EARTH + radius*sin(theta)*cos(phi)
+ y = R_EARTH + radius*sin(theta)*sin(phi)
+ z = R_EARTH + radius*cos(theta)
+
+ ! determine which points to search for in heterogen.dat
+ ! find x_low,y_low,z_low etc.
+ x_low = floor(x/delta2) + 1
+ x_high = x_low + 1
+ y_low = floor(y/delta2) + 1
+ y_high = y_low + 1
+ z_low = floor(z/delta2) + 1
+ z_high = z_low + 1
+
+ ! rho1 at: x_low y_low z_low
+ rec_read = 1+(x_low*N_R*N_R)+(y_low*N_R)+z_low
+ rho1 = HMM%rho_in(rec_read)
+
+ ! rho2 at: x_low y_high z_low
+ rec_read = 1+(x_low*N_R*N_R)+(y_high*N_R)+z_low
+ rho2 = HMM%rho_in(rec_read)
+
+ ! rho3 at: x_high y_low z_low
+ rec_read = 1+(x_high*N_R*N_R)+(y_low*N_R)+z_low
+ rho3 = HMM%rho_in(rec_read)
+
+ ! rho4 at: x_high y_high z_low
+ rec_read = 1+(x_high*N_R*N_R)+(y_high*N_R)+z_low
+ rho4 = HMM%rho_in(rec_read)
+
+ ! rho5 at: x_low y_low z_high
+ rec_read = 1+(x_low*N_R*N_R)+(y_low*N_R)+z_high
+ rho5 = HMM%rho_in(rec_read)
+
+ ! rho6 at: x_low y_high z_high
+ rec_read = 1+(x_low*N_R*N_R)+(y_high*N_R)+z_high
+ rho6 = HMM%rho_in(rec_read)
+
+ ! rho7 at: x_high y_low z_high
+ rec_read = 1+(x_high*N_R*N_R)+(y_low*N_R)+z_high
+ rho7 = HMM%rho_in(rec_read)
+
+ ! rho8 at: x_high y_high z_high
+ rec_read = 1+(x_high*N_R*N_R)+(y_high*N_R)+z_high
+ rho8 = HMM%rho_in(rec_read)
+
+ ! perform linear interpolation between the 8 points
+ a = (x-x_low*delta)/delta ! weight for x
+ b = (y-y_low*delta)/delta ! weight for y
+ c = (z-z_low*delta)/delta ! weight for z
+
+ drho = rho1*(1.-a)*(1.-b)*(1.-c) + rho2*(1.-a)*b*(1.-c) + &
+ & rho3*a*(1.-b)*(1.-c) + rho4*a*b*(1.-c) + rho5*(1.-a)*(1.-b)*c + &
+ & rho6*(1.-a)*b*c + rho7*a*(1.-b)*c + rho8*a*b*c
+
+ ! calculate delta vp,vs from the interpolated delta rho
+ dvp = (0.55/0.30)*drho
+ dvs = (1.00/0.30)*drho
+
+ else !outside of heterogeneity domain
+ drho = 0.
+ dvp = 0.
+ dvs = 0.
+ end if
+
+ end subroutine model_heterogen_mantle
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_iasp91.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_iasp91.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_iasp91.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_iasp91.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,252 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! IASP91
+!
+! Spherically symmetric isotropic IASP91 model [Kennett and Engdahl, 1991]
+!
+! B. L. N. Kennett and E. R. Engdahl, Traveltimes for global earthquake location
+! and phase identification, Geophysical Journal International, vol. 105, p. 429-465 (1991)
+!--------------------------------------------------------------------------------------------------
+
+
+ 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)
+
+
+! we use the density model of PREM (or close to PREM in the crust)
+! because IASP91 does not provide a density model.
+! Note that "ttimes" from the official IASP91 package uses a slightly different
+! model: scaling of the P wave velocity based on Birch's law. Both options are fine.
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimensionalized 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 slightly 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 ! r
+
+ endif ! check_doubling_flag
+
+
+ ! assigns model values
+
+ !
+ !--- 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
+
+ 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
+
+ ! make sure Vs is zero in the outer core even if roundoff errors on depth
+ ! also set fictitious attenuation for Qkappa to a very high value (attenuation is not used in the fluid)
+ if(idoubling == IFLAG_OUTER_CORE_NORMAL) then
+ vs = 0.d0
+ Qkappa = 0.d0
+ Qmu = ATTENUATION_COMP_MAXIMUM
+ 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/src/model_jp1d.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp1d.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_jp1d.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_jp1d.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,208 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! JP1D
+!
+! 1-D Japan model used as reference model for the 3-D model JP3D by Zhao et al. 1994
+!--------------------------------------------------------------------------------------------------
+
+
+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-dimensionalized 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/src/model_jp3d.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp3d.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_jp3d.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_jp3d.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1494 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! JP3D
+!
+! 3D japan Vp velocity model
+!
+! based on:
+!
+! 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
+!
+!
+! Last Time Modified by Min Chen, Caltech, 03/14/2008
+!
+!--------------------------------------------------------------------------------------------------
+
+ subroutine model_jp3d_broadcast(myrank,JP3DM_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_variables
+
+ integer :: myrank
+ integer :: ier
+
+ if(myrank == 0) call read_jp3d_iso_zhao_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)
+
+
+ end subroutine model_jp3d_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_jp3d_iso_zhao_model(JP3DM_V)
+
+ implicit none
+
+ include "constants.h"
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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_jp3d_iso_zhao_model
+
+!
+!==========================================================================
+!
+
+ subroutine model_jp3d_iso_zhao(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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 model_jp3d_iso_zhao
+
+!
+!---------------------------------------------------------------
+!
+
+ SUBROUTINE INPUT1(JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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"
+
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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"
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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"
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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"
+
+
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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"
+
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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"
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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"
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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"
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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"
+! model_jp3d_variables
+ type model_jp3d_variables
+ sequence
+ ! vmod3d
+ 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
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+ ! weight
+ 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)
+ ! locate integers
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ ! vmod3D integers
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ ! weight integers
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ end type model_jp3d_variables
+
+ type (model_jp3d_variables) JP3DM_V
+! model_jp3d_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/src/model_ppm.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_ppm.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_ppm.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_ppm.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1429 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+!
+! PPM - point profile models
+!
+! for generic models given as depth profiles at lon/lat using a text-file format like:
+!
+! #lon(deg), lat(deg), depth(km), Vs-perturbation wrt PREM(%), Vs-PREM (km/s)
+! -10.00000 31.00000 40.00000 -1.775005 4.400000
+! -10.00000 32.00000 40.00000 -1.056823 4.400000
+! ...
+!
+!--------------------------------------------------------------------------------------------------
+
+ module module_PPM
+
+ include "constants.h"
+
+ ! file
+ character(len=150):: PPM_file_path = "./DATA/PPM/model.txt"
+
+ ! smoothing parameters
+ logical,parameter:: GAUSS_SMOOTHING = .false.
+
+ double precision,parameter:: sigma_h = 10.0 ! 50.0 ! km, horizontal
+ double precision,parameter:: sigma_v = 10.0 ! 20.0 ! km, vertical
+
+ double precision,parameter:: pi_by180 = PI/180.0d0
+ double precision,parameter:: degtokm = pi_by180*R_EARTH_KM
+
+ double precision,parameter:: const_a = sigma_v/3.0
+ double precision,parameter:: const_b = sigma_h/3.0/(R_EARTH_KM*pi_by180)
+ integer,parameter:: NUM_GAUSSPOINTS = 10
+
+ double precision,parameter:: pi_by2 = PI/2.0d0
+ double precision,parameter:: radtodeg = 180.0d0/PI
+
+ ! ----------------------
+ ! scale perturbations in shear speed to perturbations in density and vp
+ logical,parameter:: SCALE_MODEL = .false.
+
+ ! factor to convert perturbations in shear speed to perturbations in density
+ ! taken from s20rts (see also Qin, 2009, sec. 5.2)
+ double precision, parameter :: SCALE_RHO = 0.40d0
+
+ ! SCEC version 4 model relationship http://www.data.scec.org/3Dvelocity/
+ !double precision, parameter :: SCALE_RHO = 0.254d0
+
+ ! see: P wave seismic velocity and Vp/Vs ratio beneath the Italian peninsula from local earthquake tomography
+ ! (Davide Scadi et al.,2008. tectonophysics)
+ !! becomes unstable !!
+ !double precision, parameter :: SCALE_VP = 1.75d0 ! corresponds to average vp/vs ratio
+
+ ! Zhou et al. 2005: global upper-mantle structure from finite-frequency surface-wave tomography
+ ! http://www.gps.caltech.edu/~yingz/pubs/Zhou_JGR_2005.pdf
+ !double precision, parameter :: SCALE_VP = 0.5d0 ! by lab measurements Montagner & Anderson, 1989
+
+ ! Qin et al. 2009, sec. 5.2
+ double precision, parameter :: SCALE_VP = 0.588d0 ! by Karato, 1993
+
+ end module module_PPM
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_ppm_broadcast(myrank,PPM_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+! point profile model_variables
+ type model_ppm_variables
+ sequence
+ double precision,dimension(:),pointer :: dvs,lat,lon,depth
+ double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
+ double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
+ integer :: num_v,num_latperlon,num_lonperdepth
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_ppm_variables
+ type (model_ppm_variables) PPM_V
+
+ integer :: myrank
+ integer :: ier
+
+ ! upper mantle structure
+ if(myrank == 0) call read_model_ppm(PPM_V)
+
+ ! broadcast the information read on the master to the nodes
+ call MPI_BCAST(PPM_V%num_v,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%num_latperlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%num_lonperdepth,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ if( myrank /= 0 ) then
+ allocate(PPM_V%lat(PPM_V%num_v),PPM_V%lon(PPM_V%num_v),PPM_V%depth(PPM_V%num_v),PPM_V%dvs(PPM_V%num_v))
+ endif
+ call MPI_BCAST(PPM_V%dvs(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%lat(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%lon(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%depth(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%maxlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%minlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%maxlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%minlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%maxdepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%mindepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%dlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%dlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%ddepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ end subroutine model_ppm_broadcast
+
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_model_ppm(PPM_V)
+
+ use module_PPM
+
+ implicit none
+
+ ! point profile model_variables
+ type model_ppm_variables
+ sequence
+ double precision,dimension(:),pointer :: dvs,lat,lon,depth
+ double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
+ double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
+ integer :: num_v,num_latperlon,num_lonperdepth
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_ppm_variables
+ type (model_ppm_variables) PPM_V
+
+ ! local parameters
+ integer :: ier,counter,i
+ double precision :: lon,lat,depth,dvs,vs
+ character(len=150) :: filename,line
+
+ call get_value_string(filename, 'model.PPM', trim(PPM_file_path))
+
+ !e.g. mediterranean model
+ ! counts entries
+ counter=0
+ open(unit=10,file=trim(filename),status='old',action='read',iostat=ier)
+ if( ier /= 0 ) then
+ write(IMAIN,*) ' error count opening: ',trim(filename)
+ call exit_mpi(0,"error count opening model ppm")
+ endif
+
+ ! first line is text and will be ignored
+ read(10,'(a150)') line
+
+ ! counts number of data lines
+ ier = 0
+ do while (ier == 0 )
+ read(10,*,iostat=ier) lon,lat,depth,dvs,vs
+ if( ier == 0 ) then
+ counter = counter + 1
+ endif
+ enddo
+ close(10)
+
+ PPM_V%num_v = counter
+ if( counter < 1 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' model PPM:',filename
+ write(IMAIN,*) ' no values read in!!!!!!'
+ write(IMAIN,*)
+ write(IMAIN,*)
+ call exit_mpi(0,' no model PPM ')
+ else
+ write(IMAIN,*)
+ write(IMAIN,*) 'model PPM:',trim(filename)
+ write(IMAIN,*) ' values: ',counter
+ write(IMAIN,*)
+ endif
+
+ allocate(PPM_V%lat(counter),PPM_V%lon(counter),PPM_V%depth(counter),PPM_V%dvs(counter))
+ PPM_V%min_dvs = 0.0
+ PPM_V%max_dvs = 0.0
+ PPM_V%dvs(:) = 0.0
+
+ ! vs values
+ open(unit=10,file=trim(filename),status='old',action='read',iostat=ier)
+ if( ier /= 0 ) then
+ write(IMAIN,*) ' error opening: ',trim(filename)
+ call exit_mpi(0,"error opening model ppm")
+ endif
+ read(10,'(a150)') line ! first line is text
+ counter=0
+ ier = 0
+ do while (ier == 0 )
+ read(10,*,iostat=ier) lon,lat,depth,dvs,vs
+ if( ier == 0 ) then
+ counter = counter + 1
+ PPM_V%lat(counter) = lat
+ PPM_V%lon(counter) = lon
+ PPM_V%depth(counter) = depth
+ PPM_V%dvs(counter) = dvs/100.0
+
+ !debug
+ !if( abs(depth - 100.0) < 1.e-3) write(IMAIN,*) ' lon/lat/depth : ',lon,lat,depth,' dvs:',dvs
+ endif
+ enddo
+ close(10)
+ if( counter /= PPM_V%num_v ) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' model PPM:',filename
+ write(IMAIN,*) ' error values read in!!!!!!'
+ write(IMAIN,*) ' expected: ',PPM_V%num_v
+ write(IMAIN,*) ' got: ',counter
+ call exit_mpi(0,' error model PPM ')
+ endif
+
+
+ ! gets depths (in km) of upper and lower limit
+ PPM_V%minlat = minval( PPM_V%lat(1:PPM_V%num_v) )
+ PPM_V%maxlat = maxval( PPM_V%lat(1:PPM_V%num_v) )
+
+ PPM_V%minlon = minval( PPM_V%lon(1:PPM_V%num_v) )
+ PPM_V%maxlon = maxval( PPM_V%lon(1:PPM_V%num_v) )
+
+ PPM_V%mindepth = minval( PPM_V%depth(1:PPM_V%num_v) )
+ PPM_V%maxdepth = maxval( PPM_V%depth(1:PPM_V%num_v) )
+
+ PPM_V%min_dvs = minval(PPM_V%dvs(1:PPM_V%num_v))
+ PPM_V%max_dvs = maxval(PPM_V%dvs(1:PPM_V%num_v))
+
+ write(IMAIN,*) 'model PPM:'
+ write(IMAIN,*) ' latitude min/max : ',PPM_V%minlat,PPM_V%maxlat
+ write(IMAIN,*) ' longitude min/max: ',PPM_V%minlon,PPM_V%maxlon
+ write(IMAIN,*) ' depth min/max : ',PPM_V%mindepth,PPM_V%maxdepth
+ write(IMAIN,*)
+ write(IMAIN,*) ' dvs min/max : ',PPM_V%min_dvs,PPM_V%max_dvs
+ write(IMAIN,*)
+ if( SCALE_MODEL ) then
+ write(IMAIN,*) ' scaling: '
+ write(IMAIN,*) ' rho: ',SCALE_RHO
+ write(IMAIN,*) ' vp : ',SCALE_VP
+ write(IMAIN,*)
+ endif
+ if( GAUSS_SMOOTHING ) then
+ write(IMAIN,*) ' smoothing: '
+ write(IMAIN,*) ' sigma horizontal : ',sigma_h
+ write(IMAIN,*) ' sigma vertical : ',sigma_v
+ write(IMAIN,*)
+ endif
+
+ ! steps lengths
+ PPM_V%dlat = 0.0d0
+ lat = PPM_V%lat(1)
+ do i=1,PPM_V%num_v
+ if( abs(lat - PPM_V%lat(i)) > 1.e-15 ) then
+ PPM_V%dlat = PPM_V%lat(i) - lat
+ exit
+ endif
+ enddo
+
+ PPM_V%dlon = 0.0d0
+ lon = PPM_V%lon(1)
+ do i=1,PPM_V%num_v
+ if( abs(lon - PPM_V%lon(i)) > 1.e-15 ) then
+ PPM_V%dlon = PPM_V%lon(i) - lon
+ exit
+ endif
+ enddo
+
+ PPM_V%ddepth = 0.0d0
+ depth = PPM_V%depth(1)
+ do i=1,PPM_V%num_v
+ if( abs(depth - PPM_V%depth(i)) > 1.e-15 ) then
+ PPM_V%ddepth = PPM_V%depth(i) - depth
+ exit
+ endif
+ enddo
+
+ if( abs(PPM_V%dlat) < 1.e-15 .or. abs(PPM_V%dlon) < 1.e-15 .or. abs(PPM_V%ddepth) < 1.e-15) then
+ write(IMAIN,*) ' model PPM:',filename
+ write(IMAIN,*) ' error in delta values:'
+ write(IMAIN,*) ' dlat : ',PPM_V%dlat,' dlon: ',PPM_V%dlon,' ddepth: ',PPM_V%ddepth
+ call exit_mpi(0,' error model PPM ')
+ else
+ write(IMAIN,*) ' model increments:'
+ write(IMAIN,*) ' ddepth: ',sngl(PPM_V%ddepth),' dlat:',sngl(PPM_V%dlat),' dlon:',sngl(PPM_V%dlon)
+ write(IMAIN,*)
+ endif
+
+ PPM_V%num_latperlon = int( (PPM_V%maxlat - PPM_V%minlat) / PPM_V%dlat) + 1
+ PPM_V%num_lonperdepth = int( (PPM_V%maxlon - PPM_V%minlon) / PPM_V%dlon ) + 1
+
+ end subroutine read_model_ppm
+
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_ppm(radius,theta,phi,dvs,dvp,drho,PPM_V)
+
+! returns dvs,dvp and drho for given radius,theta,phi location
+
+ use module_PPM
+
+ implicit none
+
+ ! point profile model_variables
+ type model_ppm_variables
+ sequence
+ double precision,dimension(:),pointer :: dvs,lat,lon,depth
+ double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
+ double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
+ integer :: num_v,num_latperlon,num_lonperdepth
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_ppm_variables
+ type (model_ppm_variables) PPM_V
+
+ double precision radius,theta,phi,dvs,dvp,drho
+
+ ! local parameters
+ integer:: i,j,k
+ double precision:: lat,lon,r_depth
+ double precision:: min_dvs,max_dvs
+
+ double precision:: g_dvs,g_depth,g_lat,g_lon,x,g_weight,weight_sum,weight_prod
+
+ ! initialize
+ dvs = 0.0d0
+ dvp = 0.0d0
+ drho = 0.0d0
+
+ ! depth of given radius (in km)
+ r_depth = R_EARTH_KM*(1.0 - radius) ! radius is normalized between [0,1]
+ if(r_depth>PPM_V%maxdepth .or. r_depth < PPM_V%mindepth) return
+
+ lat=(pi_by2-theta)*radtodeg
+ if( lat < PPM_V%minlat .or. lat > PPM_V%maxlat ) return
+
+ lon=phi*radtodeg
+ if(lon>180.0d0) lon=lon-360.0d0
+ if( lon < PPM_V%minlon .or. lon > PPM_V%maxlon ) return
+
+ ! search location value
+ if( .not. GAUSS_SMOOTHING ) then
+ call get_PPMmodel_value(lat,lon,r_depth,PPM_V,dvs)
+ return
+ endif
+
+ !write(IMAIN,*) ' model ppm at ',sngl(lat),sngl(lon),sngl(r_depth)
+
+ ! loop over neighboring points
+ dvs = 0.0
+ weight_sum = 0.0
+ do i=-NUM_GAUSSPOINTS,NUM_GAUSSPOINTS
+ g_depth = r_depth + i*const_a
+ do j=-NUM_GAUSSPOINTS,NUM_GAUSSPOINTS
+ g_lon = lon + j*const_b
+ do k=-NUM_GAUSSPOINTS,NUM_GAUSSPOINTS
+ g_lat = lat + k*const_b
+
+ call get_PPMmodel_value(g_lat,g_lon,g_depth,PPM_V,g_dvs)
+
+ ! horizontal weighting
+ x = (g_lat-lat)*degtokm
+ call get_Gaussianweight(x,sigma_h,g_weight)
+ g_dvs = g_dvs*g_weight
+ weight_prod = g_weight
+
+ x = (g_lon-lon)*degtokm
+ call get_Gaussianweight(x,sigma_h,g_weight)
+ g_dvs = g_dvs*g_weight
+ weight_prod = weight_prod * g_weight
+
+ !vertical weighting
+ x = g_depth-r_depth
+ call get_Gaussianweight(x,sigma_v,g_weight)
+ g_dvs = g_dvs*g_weight
+ weight_prod = weight_prod * g_weight
+
+ ! averaging
+ weight_sum = weight_sum + weight_prod
+ dvs = dvs + g_dvs
+ enddo
+ enddo
+ enddo
+
+ if( weight_sum > 1.e-15) dvs = dvs / weight_sum
+
+
+ ! store min/max
+ max_dvs = PPM_V%max_dvs
+ min_dvs = PPM_V%min_dvs
+
+ if( dvs > max_dvs ) max_dvs = dvs
+ if( dvs < min_dvs ) min_dvs = dvs
+
+ PPM_V%max_dvs = max_dvs
+ PPM_V%min_dvs = min_dvs
+
+ !write(IMAIN,*) ' dvs = ',sngl(dvs),' weight: ',sngl(weight_sum),(sngl((2*PI*sigma_h**2)*sqrt(2*PI)*sigma_v))
+
+ if( SCALE_MODEL ) then
+ ! scale density and shear velocity
+ drho = SCALE_RHO*dvs
+ ! scale vp and shear velocity
+ dvp = SCALE_VP*dvs
+ endif
+
+ end subroutine model_ppm
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine get_PPMmodel_value(lat,lon,depth,PPM_V,dvs)
+
+ implicit none
+
+ include "constants.h"
+
+ ! point profile model_variables
+ type model_ppm_variables
+ sequence
+ double precision,dimension(:),pointer :: dvs,lat,lon,depth
+ double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
+ double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
+ integer :: num_v,num_latperlon,num_lonperdepth
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_ppm_variables
+ type (model_ppm_variables) PPM_V
+
+ double precision lat,lon,depth,dvs
+
+ !integer i,j,k
+ !double precision r_top,r_bottom
+
+ integer index,num_latperlon,num_lonperdepth
+
+ dvs = 0.0
+
+ if( lat > PPM_V%maxlat ) return
+ if( lat < PPM_V%minlat ) return
+ if( lon > PPM_V%maxlon ) return
+ if( lon < PPM_V%minlon ) return
+ if( depth > PPM_V%maxdepth ) return
+ if( depth < PPM_V%mindepth ) return
+
+ ! direct access: assumes having a regular interval spacing
+ num_latperlon = PPM_V%num_latperlon ! int( (PPM_V%maxlat - PPM_V%minlat) / PPM_V%dlat) + 1
+ num_lonperdepth = PPM_V%num_lonperdepth ! int( (PPM_V%maxlon - PPM_V%minlon) / PPM_V%dlon ) + 1
+
+ index = int( (depth-PPM_V%mindepth)/PPM_V%ddepth )*num_lonperdepth*num_latperlon &
+ + int( (lon-PPM_V%minlon)/PPM_V%dlon )*num_latperlon &
+ + int( (lat-PPM_V%minlat)/PPM_V%dlat ) + 1
+ dvs = PPM_V%dvs(index)
+
+ ! ! loop-wise: slower performance
+ ! do i=1,PPM_V%num_v
+ ! ! depth
+ ! r_top = PPM_V%depth(i)
+ ! r_bottom = PPM_V%depth(i) + PPM_V%ddepth
+ ! if( depth > r_top .and. depth <= r_bottom ) then
+ ! ! longitude
+ ! do j=i,PPM_V%num_v
+ ! if( lon >= PPM_V%lon(j) .and. lon < PPM_V%lon(j)+PPM_V%dlon ) then
+ ! ! latitude
+ ! do k=j,PPM_V%num_v
+ ! if( lat >= PPM_V%lat(k) .and. lat < PPM_V%lat(k)+PPM_V%dlat ) then
+ ! dvs = PPM_V%dvs(k)
+ ! return
+ ! endif
+ ! enddo
+ ! endif
+ ! enddo
+ ! endif
+ ! enddo
+
+ end subroutine
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine get_Gaussianweight(x,sigma,weight)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision:: x,sigma,weight
+
+ double precision,parameter:: one_over2pisqrt = 0.3989422804014327
+
+ ! normalized version
+ !weight = one_over2pisqrt*exp(-0.5*x*x/(sigma*sigma))/sigma
+
+ ! only exponential
+ weight = exp(-0.5*x*x/(sigma*sigma))
+
+ end subroutine
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine smooth_model(myrank, nproc_xi,nproc_eta,&
+ rho_vp,rho_vs,nspec_stacey, &
+ iregion_code,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore,rhostore,dvpstore, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
+ nspec,HETEROGEN_3D_MANTLE, &
+ NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
+
+! smooth model parameters
+
+ implicit none
+
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ ! point profile model_variables
+ type model_ppm_variables
+ sequence
+ double precision,dimension(:),pointer :: dvs,lat,lon,depth
+ double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
+ double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
+ integer :: num_v,num_latperlon,num_lonperdepth
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_ppm_variables
+ type (model_ppm_variables) PPM_V
+
+ integer :: myrank, nproc_xi, nproc_eta
+
+ integer NEX_XI
+
+ integer nspec,nspec_stacey,NCHUNKS
+
+ logical ABSORBING_CONDITIONS
+ logical HETEROGEN_3D_MANTLE
+
+! arrays with jacobian matrix
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+! arrays with mesh parameters
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! for anisotropy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,dvpstore,kappavstore,kappahstore,&
+ muvstore,muhstore,eta_anisostore
+
+! Stacey
+ real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey)
+ real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
+
+ ! local parameters
+ integer i,j,k,ispec
+ integer iregion_code
+
+ ! only include the neighboring 3 x 3 slices
+ integer, parameter :: NSLICES = 3
+ integer ,parameter :: NSLICES2 = NSLICES * NSLICES
+
+ integer :: sizeprocs, ier, ixi, ieta
+ integer :: islice(NSLICES2), islice0(NSLICES2), nums
+
+ real(kind=CUSTOM_REAL) :: sigma_h, sigma_h2, sigma_h3, sigma_v, sigma_v2, sigma_v3
+
+ real(kind=CUSTOM_REAL) :: x0, y0, z0, norm, norm_h, norm_v, element_size
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor, exp_val
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: jacobian, jacobian0
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xl, yl, zl, xx, yy, zz
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:),allocatable :: slice_jacobian
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:),allocatable :: slice_x, slice_y, slice_z
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:),allocatable :: slice_kernels
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ks_rho,ks_kv,ks_kh,ks_muv,ks_muh,ks_eta,ks_dvp,ks_rhovp,ks_rhovs
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: tk_rho,tk_kv,tk_kh,tk_muv,tk_muh,tk_eta,tk_dvp,tk_rhovp,tk_rhovs
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: bk
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable:: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: x, y, z
+ real(kind=CUSTOM_REAL), dimension(nspec) :: cx0, cy0, cz0, cx, cy, cz
+ double precision :: starttime
+
+ integer :: ii, ispec2, rank, mychunk
+
+ ! 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 all the weights in the cube
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+ real(kind=CUSTOM_REAL), parameter :: ZERO_ = 0.0_CUSTOM_REAL
+
+ real(kind=CUSTOM_REAL) maxlat,maxlon,maxdepth
+ real(kind=CUSTOM_REAL) minlat,minlon,mindepth
+ real(kind=CUSTOM_REAL) radius,theta,phi,lat,lon,r_depth,margin_v,margin_h
+ real(kind=CUSTOM_REAL) dist_h,dist_v
+
+!----------------------------------------------------------------------------------------------------
+ ! smoothing parameters
+ logical,parameter:: GAUSS_SMOOTHING = .false. ! set to true to use this smoothing routine
+
+ sigma_h = 100.0 ! km, horizontal
+ sigma_v = 100.0 ! km, vertical
+
+ ! check if smoothing applies
+ if( .not. GAUSS_SMOOTHING ) return
+!----------------------------------------------------------------------------------------------------
+
+ ! check region: only smooth in mantle & crust
+ if( iregion_code /= IREGION_CRUST_MANTLE ) return
+
+
+ sizeprocs = NCHUNKS*NPROC_XI*NPROC_ETA
+ element_size = (TWO_PI*R_EARTH/1000.d0)/(4*NEX_XI)
+
+ if (myrank == 0) then
+ write(IMAIN, *) "model smoothing defaults:"
+ write(IMAIN, *) " NPROC_XI , NPROC_ETA, NCHUNKS: ",nproc_xi,nproc_eta,nchunks
+ write(IMAIN, *) " total processors : ",sizeprocs
+ write(IMAIN, *) " element size on surface(km): ",element_size
+ write(IMAIN, *) " smoothing sigma horizontal : ",sigma_h," vertical: ", sigma_v
+ endif
+
+
+ if (nchunks == 0) call exit_mpi(myrank,'no chunks')
+
+ element_size = element_size * 1000 ! e.g. 9 km on the surface, 36 km at CMB
+ element_size = element_size / R_EARTH
+
+ sigma_h = sigma_h * 1000.0 ! m
+ sigma_h = sigma_h / R_EARTH ! scale
+ sigma_v = sigma_v * 1000.0 ! m
+ sigma_v = sigma_v / R_EARTH ! scale
+
+ sigma_h2 = sigma_h ** 2
+ sigma_v2 = sigma_v ** 2
+
+ ! search radius
+ sigma_h3 = 3.0 * sigma_h + element_size
+ sigma_h3 = sigma_h3 ** 2
+ sigma_v3 = 3.0 * sigma_v + element_size
+ sigma_v3 = sigma_v3 ** 2
+ ! theoretic normal value
+ ! (see integral over -inf to +inf of exp[- x*x/(2*sigma) ] = sigma * sqrt(2*pi) )
+ norm_h = 2.0*PI*sigma_h**2
+ norm_v = sqrt(2.0*PI) * sigma_v
+ norm = norm_h * norm_v
+
+ if (myrank == 0) then
+ write(IMAIN, *) " spectral elements : ",nspec
+ write(IMAIN, *) " normalization factor : ",norm
+ endif
+
+ ! GLL points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
+ enddo
+ enddo
+ enddo
+
+ ! ---- figure out the neighboring 8 or 7 slices: (ichunk,ixi,ieta) index start at 0------
+ ! note: ichunk is set to CHUNK_AB etc., while mychunk starts from 0
+ mychunk = myrank / (nproc_xi * nproc_eta)
+ ieta = (myrank - mychunk * nproc_xi * nproc_eta) / nproc_xi
+ ixi = myrank - mychunk * nproc_xi * nproc_eta - ieta * nproc_xi
+
+ ! get the neighboring slices:
+ call get_all_eight_slices(mychunk,ixi,ieta,&
+ islice0(1),islice0(2),islice0(3),islice0(4),islice0(5),islice0(6),islice0(7),islice0(8),&
+ nproc_xi,nproc_eta)
+
+ ! remove the repeated slices (only 8 for corner slices in global case)
+ islice(1) = myrank; j = 1
+ do i = 1, 8
+ if (.not. any(islice(1:i) == islice0(i)) .and. islice0(i) < sizeprocs) then
+ j = j + 1
+ islice(j) = islice0(i)
+ endif
+ enddo
+ nums = j
+
+ if( myrank == 0 ) then
+ write(IMAIN, *) 'slices:',nums
+ write(IMAIN, *) ' ',islice(1:nums)
+ write(IMAIN, *)
+ endif
+
+ ! read in the topology files of the current and neighboring slices
+ ! read in myrank slice
+ xl(:,:,:,:) = xstore(:,:,:,:)
+ yl(:,:,:,:) = ystore(:,:,:,:)
+ zl(:,:,:,:) = zstore(:,:,:,:)
+
+ ! build jacobian
+ allocate(xix(NGLLX,NGLLY,NGLLZ,nspec),xiy(NGLLX,NGLLY,NGLLZ,nspec),xiz(NGLLX,NGLLY,NGLLZ,nspec))
+ xix(:,:,:,:) = xixstore(:,:,:,:)
+ xiy(:,:,:,:) = xiystore(:,:,:,:)
+ xiz(:,:,:,:) = xizstore(:,:,:,:)
+
+ allocate(etax(NGLLX,NGLLY,NGLLZ,nspec),etay(NGLLX,NGLLY,NGLLZ,nspec),etaz(NGLLX,NGLLY,NGLLZ,nspec))
+ etax(:,:,:,:) = etaxstore(:,:,:,:)
+ etay(:,:,:,:) = etaystore(:,:,:,:)
+ etaz(:,:,:,:) = etazstore(:,:,:,:)
+
+ allocate(gammax(NGLLX,NGLLY,NGLLZ,nspec),gammay(NGLLX,NGLLY,NGLLZ,nspec),gammaz(NGLLX,NGLLY,NGLLZ,nspec))
+ gammax(:,:,:,:) = gammaxstore(:,:,:,:)
+ gammay(:,:,:,:) = gammaystore(:,:,:,:)
+ gammaz(:,:,:,:) = gammazstore(:,:,:,:)
+
+
+ ! get the location of the center of the elements
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ! build jacobian
+ ! 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 = xixl*(etayl*gammazl-etazl*gammayl) - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl)
+
+ if( abs(jacobianl) > 1.e-25 ) then
+ jacobianl = 1.0_CUSTOM_REAL / jacobianl
+ else
+ jacobianl = ZERO_
+ endif
+
+ jacobian(i,j,k,ispec) = jacobianl
+ enddo
+ enddo
+ enddo
+ cx0(ispec) = (xl(1,1,1,ispec) + xl(NGLLX,NGLLY,NGLLZ,ispec))*0.5
+ cy0(ispec) = (yl(1,1,1,ispec) + yl(NGLLX,NGLLY,NGLLZ,ispec))*0.5
+ cz0(ispec) = (zl(1,1,1,ispec) + zl(NGLLX,NGLLY,NGLLZ,ispec))*0.5
+ enddo
+ jacobian0(:,:,:,:) = jacobian(:,:,:,:)
+
+ deallocate(xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+ if (myrank == 0) write(IMAIN, *) 'distributing locations, jacobians and model values ...'
+ call mpi_barrier(MPI_COMM_WORLD,ier)
+
+ ! get location/jacobian info from slices
+ allocate( slice_x(NGLLX,NGLLY,NGLLZ,NSPEC,nums))
+ allocate( slice_y(NGLLX,NGLLY,NGLLZ,NSPEC,nums))
+ allocate( slice_z(NGLLX,NGLLY,NGLLZ,NSPEC,nums))
+ allocate( slice_jacobian(NGLLX,NGLLY,NGLLZ,NSPEC,nums))
+ do rank=0,sizeprocs-1
+ if( rank == myrank) then
+ jacobian(:,:,:,:) = jacobian0(:,:,:,:)
+ x(:,:,:,:) = xstore(:,:,:,:)
+ y(:,:,:,:) = ystore(:,:,:,:)
+ z(:,:,:,:) = zstore(:,:,:,:)
+ endif
+ ! every process broadcasts its info
+ call MPI_BCAST(x,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(y,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(z,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(jacobian,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+
+ ! only relevant process info gets stored
+ do ii=1,nums
+ if( islice(ii) == rank ) then
+ slice_x(:,:,:,:,ii) = x(:,:,:,:)
+ slice_y(:,:,:,:,ii) = y(:,:,:,:)
+ slice_z(:,:,:,:,ii) = z(:,:,:,:)
+ slice_jacobian(:,:,:,:,ii) = jacobian(:,:,:,:)
+ endif
+ enddo
+ enddo
+
+ ! arrays to smooth
+ allocate( slice_kernels(NGLLX,NGLLY,NGLLZ,NSPEC,nums,9))
+ do rank=0,sizeprocs-1
+ if( rank == myrank) then
+ ks_rho(:,:,:,:) = rhostore(:,:,:,:)
+ ks_kv(:,:,:,:) = kappavstore(:,:,:,:)
+ ks_kh(:,:,:,:) = kappahstore(:,:,:,:)
+ ks_muv(:,:,:,:) = muvstore(:,:,:,:)
+ ks_muh(:,:,:,:) = muhstore(:,:,:,:)
+ ks_eta(:,:,:,:) = eta_anisostore(:,:,:,:)
+ if( HETEROGEN_3D_MANTLE ) then
+ ks_dvp(:,:,:,:) = dvpstore(:,:,:,:)
+ endif
+ if( ABSORBING_CONDITIONS ) then
+ if( iregion_code == IREGION_CRUST_MANTLE) then
+ ks_rhovp(:,:,:,1:nspec_stacey) = rho_vp(:,:,:,1:nspec_stacey)
+ ks_rhovs(:,:,:,1:nspec_stacey) = rho_vs(:,:,:,1:nspec_stacey)
+ endif
+ endif
+ ! in case of
+ !if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
+ ! or
+ !if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ ! or
+ !if(ATTENUATION .and. ATTENUATION_3D) then
+ ! one should add the c**store and tau_* arrays here as well
+ endif
+ ! every process broadcasts its info
+ call MPI_BCAST(ks_rho,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ks_kv,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ks_kh,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ks_muv,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ks_muh,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ks_eta,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ks_dvp,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ks_rhovp,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ks_rhovs,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
+
+ ! only relevant process info gets stored
+ do ii=1,nums
+ if( islice(ii) == rank ) then
+ slice_kernels(:,:,:,:,ii,1) = ks_rho(:,:,:,:)
+ slice_kernels(:,:,:,:,ii,2) = ks_kv(:,:,:,:)
+ slice_kernels(:,:,:,:,ii,3) = ks_kh(:,:,:,:)
+ slice_kernels(:,:,:,:,ii,4) = ks_muv(:,:,:,:)
+ slice_kernels(:,:,:,:,ii,5) = ks_muh(:,:,:,:)
+ slice_kernels(:,:,:,:,ii,6) = ks_eta(:,:,:,:)
+ slice_kernels(:,:,:,:,ii,7) = ks_dvp(:,:,:,:)
+ slice_kernels(:,:,:,:,ii,8) = ks_rhovp(:,:,:,:)
+ slice_kernels(:,:,:,:,ii,9) = ks_rhovs(:,:,:,:)
+ endif
+ enddo
+ enddo
+
+ ! get the global maximum value of the original kernel file
+ !call mpi_barrier(MPI_COMM_WORLD,ier)
+ !call mpi_reduce(maxval(abs(muvstore(:,:,:,:))), max_old, 1, &
+ ! CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+
+ if (myrank == 0) write(IMAIN, *) 'start looping over elements and points for smoothing ...'
+
+! loop over all the slices
+ tk_rho(:,:,:,:) = 0.0_CUSTOM_REAL
+ tk_kh(:,:,:,:) = 0.0_CUSTOM_REAL
+ tk_kv(:,:,:,:) = 0.0_CUSTOM_REAL
+ tk_muh(:,:,:,:) = 0.0_CUSTOM_REAL
+ tk_muv(:,:,:,:) = 0.0_CUSTOM_REAL
+ tk_eta(:,:,:,:) = 0.0_CUSTOM_REAL
+ tk_dvp(:,:,:,:) = 0.0_CUSTOM_REAL
+ tk_rhovp(:,:,:,:) = 0.0_CUSTOM_REAL
+ tk_rhovs(:,:,:,:) = 0.0_CUSTOM_REAL
+
+ bk(:,:,:,:) = 0.0_CUSTOM_REAL
+ do ii = 1, nums
+ if (myrank == 0) starttime = MPI_WTIME()
+ if (myrank == 0) write(IMAIN, *) ' slice number = ', ii
+
+ ! read in the topology, jacobian, calculate center of elements
+ xx(:,:,:,:) = slice_x(:,:,:,:,ii)
+ yy(:,:,:,:) = slice_y(:,:,:,:,ii)
+ zz(:,:,:,:) = slice_z(:,:,:,:,ii)
+ jacobian(:,:,:,:) = slice_jacobian(:,:,:,:,ii)
+
+ ! get the location of the center of the elements
+ do ispec2 = 1, nspec
+ cx(ispec2) = (xx(1,1,1,ispec2) + xx(NGLLX,NGLLZ,NGLLY,ispec2))*0.5
+ cy(ispec2) = (yy(1,1,1,ispec2) + yy(NGLLX,NGLLZ,NGLLY,ispec2))*0.5
+ cz(ispec2) = (zz(1,1,1,ispec2) + zz(NGLLX,NGLLZ,NGLLY,ispec2))*0.5
+ enddo
+
+ !if (myrank == 0) write(IMAIN, *) ' location:',cx(1),cy(1),cz(1)
+ !if (myrank == 0) write(IMAIN, *) ' dist:',(cx(1)-cx0(1))**2+(cy(1)-cy0(1))**2,(cz(1)-cz0(1))**2
+ !if (myrank == 0) write(IMAIN, *) ' sigma:',sigma_h3,sigma_v3
+
+ ! array values
+ ks_rho(:,:,:,:) = slice_kernels(:,:,:,:,ii,1)
+ ks_kv(:,:,:,:) = slice_kernels(:,:,:,:,ii,2)
+ ks_kh(:,:,:,:) = slice_kernels(:,:,:,:,ii,3)
+ ks_muv(:,:,:,:) = slice_kernels(:,:,:,:,ii,4)
+ ks_muh(:,:,:,:) = slice_kernels(:,:,:,:,ii,5)
+ ks_eta(:,:,:,:) = slice_kernels(:,:,:,:,ii,6)
+ ks_dvp(:,:,:,:) = slice_kernels(:,:,:,:,ii,7)
+ ks_rhovp(:,:,:,:) = slice_kernels(:,:,:,:,ii,8)
+ ks_rhovs(:,:,:,:) = slice_kernels(:,:,:,:,ii,9)
+
+ ! loop over elements to be smoothed in the current slice
+ do ispec = 1, nspec
+
+ if (myrank == 0 .and. mod(ispec,100) == 0 ) write(IMAIN, *) ' ispec ', ispec,' sec:',MPI_WTIME()-starttime
+
+ ! --- only double loop over the elements in the search radius ---
+ do ispec2 = 1, nspec
+
+ ! calculates horizontal and vertical distance between two element centers
+
+ ! vector approximation
+ call get_distance_vec(dist_h,dist_v,cx0(ispec),cy0(ispec),cz0(ispec),&
+ cx(ispec2),cy(ispec2),cz(ispec2))
+
+ ! note: distances and sigmah, sigmav are normalized by R_EARTH
+
+ ! checks distance between centers of elements
+ if ( dist_h > sigma_h3 .or. abs(dist_v) > sigma_v3 ) cycle
+
+
+
+ factor(:,:,:) = jacobian(:,:,:,ispec2) * wgll_cube(:,:,:) ! integration factors
+
+ ! loop over GLL points of the elements in current slice (ispec)
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ ! current point (i,j,k,ispec) location, cartesian coordinates
+ x0 = xl(i,j,k,ispec)
+ y0 = yl(i,j,k,ispec)
+ z0 = zl(i,j,k,ispec)
+
+ ! calculate weights based on gaussian smoothing
+ call smoothing_weights_vec(x0,y0,z0,ispec2,sigma_h2,sigma_v2,exp_val,&
+ xx(:,:,:,ispec2),yy(:,:,:,ispec2),zz(:,:,:,ispec2))
+
+ ! adds GLL integration weights
+ exp_val(:,:,:) = exp_val(:,:,:) * factor(:,:,:)
+
+
+ ! smoothed kernel values
+ tk_rho(i,j,k,ispec) = tk_rho(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_rho(:,:,:,ispec2))
+ tk_kv(i,j,k,ispec) = tk_kv(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_kv(:,:,:,ispec2))
+ tk_kh(i,j,k,ispec) = tk_kh(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_kh(:,:,:,ispec2))
+ tk_muv(i,j,k,ispec) = tk_muv(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_muv(:,:,:,ispec2))
+ tk_muh(i,j,k,ispec) = tk_muh(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_muh(:,:,:,ispec2))
+ tk_eta(i,j,k,ispec) = tk_eta(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_eta(:,:,:,ispec2))
+ tk_dvp(i,j,k,ispec) = tk_dvp(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_dvp(:,:,:,ispec2))
+ tk_rhovp(i,j,k,ispec) = tk_rhovp(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_rhovp(:,:,:,ispec2))
+ tk_rhovs(i,j,k,ispec) = tk_rhovs(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_rhovs(:,:,:,ispec2))
+
+ ! normalization, integrated values of gaussian smoothing function
+ bk(i,j,k,ispec) = bk(i,j,k,ispec) + sum(exp_val(:,:,:))
+
+ enddo
+ enddo
+ enddo ! (i,j,k)
+ enddo ! (ispec2)
+ enddo ! (ispec)
+ enddo ! islice
+
+ if (myrank == 0) write(IMAIN, *) 'Done with integration ...'
+
+ ! gets depths (in km) of upper and lower limit
+ maxlat = PPM_V%maxlat
+ minlat = PPM_V%minlat
+
+ maxlon = PPM_V%maxlon
+ minlon = PPM_V%minlon
+
+ maxdepth = PPM_V%maxdepth
+ mindepth = PPM_V%mindepth
+
+ margin_v = sigma_v*R_EARTH/1000.0 ! in km
+ margin_h = sigma_h*R_EARTH/1000.0 * 180.0/(R_EARTH_KM*PI) ! in degree
+
+ ! computes the smoothed values
+ do ispec = 1, nspec
+
+ ! depth of given radius (in km)
+ call xyz_2_rthetaphi(cx0(ispec),cy0(ispec),cz0(ispec),radius,theta,phi)
+ r_depth = R_EARTH_KM - radius*R_EARTH_KM ! radius is normalized between [0,1]
+ if(r_depth>=maxdepth+margin_v .or. r_depth+margin_v < mindepth) cycle
+
+ lat=(PI/2.0d0-theta)*180.0d0/PI
+ if( lat < minlat-margin_h .or. lat > maxlat+margin_h ) cycle
+
+ lon=phi*180.0d0/PI
+ if(lon>180.0d0) lon=lon-360.0d0
+ if( lon < minlon-margin_h .or. lon > maxlon+margin_h ) cycle
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ ! check if bk value has an entry
+ if (abs(bk(i,j,k,ispec) ) > 1.e-25 ) then
+
+ ! check if (integrated) normalization value is close to theoretically one
+ if (abs(bk(i,j,k,ispec) - norm) > 1.e-3*norm ) then ! check the normalization criterion
+ print *, 'Problem here --- ', myrank, ispec, i, j, k, bk(i,j,k,ispec), norm
+ call exit_mpi(myrank, 'Error computing Gaussian function on the grid')
+ endif
+
+ rhostore(i,j,k,ispec) = tk_rho(i,j,k,ispec) / bk(i,j,k,ispec)
+ kappavstore(i,j,k,ispec) = tk_kv(i,j,k,ispec) / bk(i,j,k,ispec)
+ kappahstore(i,j,k,ispec) = tk_kh(i,j,k,ispec) / bk(i,j,k,ispec)
+ muvstore(i,j,k,ispec) = tk_muv(i,j,k,ispec) / bk(i,j,k,ispec)
+ muhstore(i,j,k,ispec) = tk_muh(i,j,k,ispec) / bk(i,j,k,ispec)
+ eta_anisostore(i,j,k,ispec) = tk_eta(i,j,k,ispec) / bk(i,j,k,ispec)
+ if( HETEROGEN_3D_MANTLE ) then
+ dvpstore(i,j,k,ispec) = tk_dvp(i,j,k,ispec) / bk(i,j,k,ispec)
+ endif
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ if( ABSORBING_CONDITIONS ) then
+ if( iregion_code == IREGION_CRUST_MANTLE) then
+ do ispec = 1, nspec_stacey
+
+ ! depth of given radius (in km)
+ call xyz_2_rthetaphi(cx0(ispec),cy0(ispec),cz0(ispec),radius,theta,phi)
+ r_depth = R_EARTH_KM - radius*R_EARTH_KM ! radius is normalized between [0,1]
+ if(r_depth>=maxdepth+margin_v .or. r_depth+margin_v < mindepth) cycle
+
+ lat=(PI/2.0d0-theta)*180.0d0/PI
+ if( lat < minlat-margin_h .or. lat > maxlat+margin_h ) cycle
+
+ lon=phi*180.0d0/PI
+ if(lon>180.0d0) lon=lon-360.0d0
+ if( lon < minlon-margin_h .or. lon > maxlon+margin_h ) cycle
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ ! check if bk value has an entry
+ if (abs(bk(i,j,k,ispec) ) > 1.e-25 ) then
+ rho_vp(i,j,k,ispec) = tk_rhovp(i,j,k,ispec)/bk(i,j,k,ispec)
+ rho_vs(i,j,k,ispec) = tk_rhovs(i,j,k,ispec)/bk(i,j,k,ispec)
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ endif
+
+ !if (myrank == 0) write(IMAIN, *) 'Maximum data value before smoothing = ', max_old
+
+ ! the maximum value for the smoothed kernel
+ !call mpi_barrier(MPI_COMM_WORLD,ier)
+ !call mpi_reduce(maxval(abs(muvstore(:,:,:,:))), max_new, 1, &
+ ! CUSTOM_MPI_TYPE, MPI_MAX, 0, MPI_COMM_WORLD,ier)
+
+ !if (myrank == 0) then
+ ! write(IMAIN, *) 'Maximum data value after smoothing = ', max_new
+ ! write(IMAIN, *)
+ !endif
+ !call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+ end subroutine
+
+!
+! -----------------------------------------------------------------------------
+!
+ subroutine smoothing_weights_vec(x0,y0,z0,ispec2,sigma_h2,sigma_v2,exp_val,&
+ xx_elem,yy_elem,zz_elem)
+
+ implicit none
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ),intent(out) :: exp_val
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ),intent(in) :: xx_elem, yy_elem, zz_elem
+ real(kind=CUSTOM_REAL),intent(in) :: x0,y0,z0,sigma_h2,sigma_v2
+ integer,intent(in) :: ispec2
+
+ ! local parameters
+ integer :: ii,jj,kk
+ real(kind=CUSTOM_REAL) :: dist_h,dist_v
+ !real(kind=CUSTOM_REAL) :: r0,r1,theta1
+
+ ! >>>>>
+ ! uniform sigma
+ ! just to avoid compiler warning
+ ii = ispec2
+ !exp_val(:,:,:) = exp( -((xx(:,:,:,ispec2)-x0)**2+(yy(:,:,:,ispec2)-y0)**2 &
+ ! +(zz(:,:,:,ispec2)-z0)**2 )/(2*sigma2) )*factor(:,:,:)
+
+ ! from basin code smoothing:
+ ! gaussian function
+ !exp_val(:,:,:) = exp( -(xx(:,:,:,ispec2)-x0)**2/(sigma_h2) &
+ ! -(yy(:,:,:,ispec2)-y0)**2/(sigma_h2) &
+ ! -(zz(:,:,:,ispec2)-z0)**2/(sigma_v2) ) * factor(:,:,:)
+ ! >>>>>
+
+ do kk = 1, NGLLZ
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ ! point in second slice
+
+ ! vector approximation:
+ call get_distance_vec(dist_h,dist_v,x0,y0,z0, &
+ xx_elem(ii,jj,kk),yy_elem(ii,jj,kk),zz_elem(ii,jj,kk))
+
+ ! gaussian function
+ exp_val(ii,jj,kk) = exp( - dist_h*dist_h/sigma_h2 &
+ - dist_v*dist_v/sigma_v2 ) ! * factor(ii,jj,kk)
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine smoothing_weights_vec
+
+
+!
+! -----------------------------------------------------------------------------
+!
+
+ subroutine get_distance_vec(dist_h,dist_v,x0,y0,z0,x1,y1,z1)
+
+! returns vector lengths as distances in radial and horizontal direction
+
+ implicit none
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL),intent(out) :: dist_h,dist_v
+ real(kind=CUSTOM_REAL),intent(in) :: x0,y0,z0,x1,y1,z1
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: r0,r1,alpha
+ real(kind=CUSTOM_REAL) :: vx,vy,vz
+
+ ! vertical distance
+ r0 = sqrt( x0*x0 + y0*y0 + z0*z0 ) ! length of first position vector
+ r1 = sqrt( x1*x1 + y1*y1 + z1*z1 )
+ dist_v = r1 - r0
+ ! only for flat earth with z in depth: dist_v = sqrt( (cz(ispec2)-cz0(ispec))** 2)
+
+ ! horizontal distance
+ ! length of vector from point 0 to point 1
+ ! assuming small earth curvature (since only for neighboring elements)
+
+ ! scales r0 to have same length as r1
+ alpha = r1 / r0
+ vx = alpha * x0
+ vy = alpha * y0
+ vz = alpha * z0
+
+ ! vector in horizontal between new r0 and r1
+ vx = x1 - vx
+ vy = y1 - vy
+ vz = z1 - vz
+
+ ! distance is vector length
+ dist_h = sqrt( vx*vx + vy*vy + vz*vz )
+
+ end subroutine get_distance_vec
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine get_all_eight_slices(ichunk,ixi,ieta,&
+ ileft,iright,ibot,itop, ilb,ilt,irb,irt,&
+ nproc_xi,nproc_eta)
+
+ implicit none
+
+ integer, intent(IN) :: ichunk,ixi,ieta,nproc_xi,nproc_eta
+
+ integer, intent(OUT) :: ileft,iright,ibot,itop,ilb,ilt,irb,irt
+ integer :: get_slice_number
+
+
+ integer :: ichunk_left, islice_xi_left, islice_eta_left, &
+ ichunk_right, islice_xi_right, islice_eta_right, &
+ ichunk_bot, islice_xi_bot, islice_eta_bot, &
+ ichunk_top, islice_xi_top, islice_eta_top, &
+ ileft0,iright0,ibot0,itop0, &
+ ichunk_left0, islice_xi_left0, islice_eta_left0, &
+ ichunk_right0, islice_xi_right0, islice_eta_right0, &
+ ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
+ ichunk_top0, islice_xi_top0, islice_eta_top0
+
+
+! get the first 4 immediate slices
+ call get_lrbt_slices(ichunk,ixi,ieta, &
+ ileft, ichunk_left, islice_xi_left, islice_eta_left, &
+ iright, ichunk_right, islice_xi_right, islice_eta_right, &
+ ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
+ itop, ichunk_top, islice_xi_top, islice_eta_top, &
+ nproc_xi,nproc_eta)
+
+! get the 4 diagonal neighboring slices (actually 3 diagonal slices at the corners)
+ ilb = get_slice_number(ichunk,ixi-1,ieta-1,nproc_xi,nproc_eta)
+ ilt = get_slice_number(ichunk,ixi-1,ieta+1,nproc_xi,nproc_eta)
+ irb = get_slice_number(ichunk,ixi+1,ieta-1,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk,ixi+1,ieta+1,nproc_xi,nproc_eta)
+
+ if (ixi==0) then
+ call get_lrbt_slices(ichunk_left,islice_xi_left,islice_eta_left, &
+ ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
+ iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
+ ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
+ itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
+ nproc_xi,nproc_eta)
+
+ if (ichunk == 0 .or. ichunk == 1 .or. ichunk == 3 .or. ichunk == 5) then
+ ilb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ ilt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ else if (ichunk == 2) then
+ ilb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ ilt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ else
+ ilb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ ilt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ endif
+ endif
+
+ if (ixi==nproc_xi-1) then
+ call get_lrbt_slices(ichunk_right,islice_xi_right,islice_eta_right, &
+ ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
+ iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
+ ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
+ itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
+ nproc_xi,nproc_eta)
+ if (ichunk == 0 .or. ichunk == 1 .or. ichunk == 3 .or. ichunk == 5) then
+ irb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ else if (ichunk == 2) then
+ irb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ else
+ irb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ endif
+ endif
+
+ if (ieta==0) then
+ call get_lrbt_slices(ichunk_bot,islice_xi_bot,islice_eta_bot, &
+ ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
+ iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
+ ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
+ itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
+ nproc_xi,nproc_eta)
+ if (ichunk == 1 .or. ichunk == 2) then
+ ilb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ irb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ else if (ichunk == 3 .or. ichunk == 4) then
+ ilb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ irb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ else if (ichunk == 0) then
+ ilb = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ irb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ else
+ ilb = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ irb = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ endif
+ endif
+
+ if (ieta==nproc_eta-1) then
+ call get_lrbt_slices(ichunk_top,islice_xi_top,islice_eta_top, &
+ ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
+ iright0, ichunk_right0, islice_xi_right0, islice_eta_right0, &
+ ibot0, ichunk_bot0, islice_xi_bot0, islice_eta_bot0, &
+ itop0, ichunk_top0, islice_xi_top0, islice_eta_top0, &
+ nproc_xi,nproc_eta)
+
+ if (ichunk == 1 .or. ichunk == 4) then
+ ilt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ else if (ichunk == 2 .or. ichunk == 3) then
+ ilt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
+ else if (ichunk == 0) then
+ ilt = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ else
+ ilt = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
+ irt = get_slice_number(ichunk_bot0,islice_xi_bot0,islice_eta_bot0,nproc_xi,nproc_eta)
+ endif
+
+ endif
+
+ end subroutine get_all_eight_slices
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine get_lrbt_slices(ichunk,ixi,ieta, &
+ ileft, ichunk_left, islice_xi_left, islice_eta_left, &
+ iright, ichunk_right, islice_xi_right, islice_eta_right, &
+ ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
+ itop, ichunk_top, islice_xi_top, islice_eta_top, &
+ nproc_xi,nproc_eta)
+
+ implicit none
+
+ integer, intent(IN) :: ichunk, ixi, ieta, nproc_xi, nproc_eta
+ integer, intent(OUT) :: ileft, ichunk_left, islice_xi_left, islice_eta_left, &
+ iright, ichunk_right, islice_xi_right, islice_eta_right, &
+ ibot, ichunk_bot, islice_xi_bot, islice_eta_bot, &
+ itop, ichunk_top, islice_xi_top, islice_eta_top
+
+ integer, parameter :: NCHUNKS = 6
+
+ integer, dimension(NCHUNKS) :: chunk_left,chunk_right,chunk_bot,chunk_top, &
+ slice_xi_left,slice_eta_left,slice_xi_right,slice_eta_right, &
+ slice_xi_bot,slice_eta_bot,slice_xi_top,slice_eta_top
+ integer :: get_slice_number
+
+! set up mapping arrays -- assume chunk/slice number starts from 0
+ chunk_left(:) = (/2,6,6,1,6,4/) - 1
+ chunk_right(:) = (/4,1,1,6,1,2/) - 1
+ chunk_bot(:) = (/5,5,2,5,4,5/) - 1
+ chunk_top(:) = (/3,3,4,3,2,3/) - 1
+
+ slice_xi_left(:) = (/nproc_xi-1,nproc_xi-1,nproc_xi-1-ieta,nproc_xi-1,ieta,nproc_xi-1/)
+ slice_eta_left(:) = (/ieta,ieta,nproc_eta-1,ieta,0,ieta/)
+ slice_xi_right(:) = (/0,0,ieta,0,nproc_xi-1-ieta,0/)
+ slice_eta_right(:) = (/ieta,ieta,nproc_eta-1,ieta,0,ieta/)
+
+ slice_xi_bot(:) = (/nproc_xi-1,ixi,ixi,nproc_xi-1-ixi,nproc_xi-1-ixi,0/)
+ slice_eta_bot(:) = (/nproc_eta-1-ixi,nproc_eta-1,nproc_eta-1,0,0,ixi/)
+ slice_xi_top(:) = (/nproc_xi-1,ixi,nproc_xi-1-ixi,nproc_xi-1-ixi,ixi,0/)
+ slice_eta_top(:) = (/ixi,0,nproc_eta-1,nproc_eta-1,0,nproc_eta-1-ixi /)
+
+ ichunk_left = ichunk
+ ichunk_right = ichunk
+ ichunk_bot = ichunk
+ ichunk_top = ichunk
+
+ islice_xi_left = ixi-1
+ islice_eta_left = ieta
+ islice_xi_right = ixi+1
+ islice_eta_right = ieta
+
+ islice_xi_bot = ixi
+ islice_eta_bot = ieta-1
+ islice_xi_top = ixi
+ islice_eta_top = ieta+1
+
+ if (ixi == 0) then
+ ichunk_left=chunk_left(ichunk+1)
+ islice_xi_left=slice_xi_left(ichunk+1)
+ islice_eta_left=slice_eta_left(ichunk+1)
+ endif
+ if (ixi == nproc_xi - 1) then
+ ichunk_right=chunk_right(ichunk+1)
+ islice_xi_right=slice_xi_right(ichunk+1)
+ islice_eta_right=slice_eta_right(ichunk+1)
+ endif
+ if (ieta == 0) then
+ ichunk_bot=chunk_bot(ichunk+1)
+ islice_xi_bot=slice_xi_bot(ichunk+1)
+ islice_eta_bot=slice_eta_bot(ichunk+1)
+ endif
+ if (ieta == nproc_eta - 1) then
+ ichunk_top=chunk_top(ichunk+1)
+ islice_xi_top=slice_xi_top(ichunk+1)
+ islice_eta_top=slice_eta_top(ichunk+1)
+ endif
+
+ ileft = get_slice_number(ichunk_left,islice_xi_left,islice_eta_left,nproc_xi,nproc_eta)
+ iright = get_slice_number(ichunk_right,islice_xi_right,islice_eta_right,nproc_xi,nproc_eta)
+ ibot = get_slice_number(ichunk_bot,islice_xi_bot,islice_eta_bot,nproc_xi,nproc_eta)
+ itop = get_slice_number(ichunk_top,islice_xi_top,islice_eta_top,nproc_xi,nproc_eta)
+
+ end subroutine get_lrbt_slices
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ integer function get_slice_number(ichunk,ixi,ieta,nproc_xi,nproc_eta)
+
+ implicit none
+
+ integer :: ichunk, ixi, ieta, nproc_xi, nproc_eta
+
+ get_slice_number = ichunk*nproc_xi*nproc_eta+ieta*nproc_xi+ixi
+
+ end function get_slice_number
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_prem.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_prem.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_prem.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_prem.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,627 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+!
+! PREM [Dziewonski and Anderson, 1981].
+!
+! A. M. Dziewonski and D. L. Anderson.
+! Preliminary reference Earth model.
+! Phys. Earth Planet. Inter., 25:297–356, 1981.
+!
+! Isotropic (iso) and transversely isotropic (aniso) version of the
+! spherically symmetric Preliminary Reference Earth Model
+!
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_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-dimensionalized 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 in model_prem_iso()')
+ !
+ !--- 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 in model_prem_iso()')
+ !
+ !--- 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 in model_prem_iso()')
+ !
+ !--- 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 in model_prem_iso()')
+ !
+ !--- 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 in model_prem_iso()')
+ !
+ !--- 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 in model_prem_iso()')
+ 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
+ ! density/velocity from mantle just below moho
+ drhodr=0.6924d0
+ rho=2.6910d0+0.6924d0*x
+ vp=4.1875d0+3.9382d0*x
+ vs=2.1519d0+2.3481d0*x
+ ! shear attenuation for R80 to surface
+ 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 model_prem_iso
+
+!
+!=====================================================================
+!
+
+ subroutine model_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-dimensionalized 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 in model_prem_aniso()')
+!
+!--- 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 in model_prem_aniso()')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) then
+ print*,'error dprime point:',r, RCMB,RTOPDDOUBLEPRIME,idoubling,IFLAG_MANTLE_NORMAL
+ call exit_MPI(myrank,'wrong doubling flag for D" point in model_prem_aniso()')
+ endif
+!
+!--- 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 in model_prem_aniso()')
+
+!
+!--- 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 in model_prem_aniso()')
+
+!
+!--- 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 in model_prem_aniso()')
+
+ 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 model_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-dimensionalized 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 in prem_display_outer_core()')
+
+!
+!--- 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
+
+ ! compute real physical radius in meters
+ r = x * R_EARTH
+
+ ! calculates density according to radius
+ 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/src/model_s20rts.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_s20rts.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_s20rts.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_s20rts.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,515 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! S20rts
+!
+! 3D mantle model S20RTS [Ritsema et al., 1999]
+!
+! Note that S20RTS uses transversely isotropic PREM as a background
+! model, and that we use the PREM radial attenuation model when ATTENUATION is incorporated.
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_s20rts_broadcast(myrank,S20RTS_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+! model_s20rts_variables s20rts
+ type model_s20rts_variables
+ sequence
+ double precision dvs_a(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvs_b(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvp_a(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvp_b(0:NK_20,0:NS_20,0:NS_20)
+ double precision spknt(NK_20+1)
+ double precision qq0(NK_20+1,NK_20+1)
+ double precision qq(3,NK_20+1,NK_20+1)
+ end type model_s20rts_variables
+
+ type (model_s20rts_variables) S20RTS_V
+! model_s20rts_variables
+
+ integer :: myrank
+ integer :: ier
+
+ ! the variables read are declared and stored in structure S20RTS_V
+ if(myrank == 0) call read_model_s20rts(S20RTS_V)
+
+ ! broadcast the information read on the master to the nodes
+ call MPI_BCAST(S20RTS_V%dvs_a,(NK_20+1)*(NS_20+1)*(NS_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S20RTS_V%dvs_b,(NK_20+1)*(NS_20+1)*(NS_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S20RTS_V%dvp_a,(NK_20+1)*(NS_20+1)*(NS_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S20RTS_V%dvp_b,(NK_20+1)*(NS_20+1)*(NS_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S20RTS_V%spknt,NK_20+1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S20RTS_V%qq0,(NK_20+1)*(NK_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S20RTS_V%qq,3*(NK_20+1)*(NK_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ end subroutine model_s20rts_broadcast
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_model_s20rts(S20RTS_V)
+
+ implicit none
+
+ include "constants.h"
+
+! model_s20rts_variables
+ type model_s20rts_variables
+ sequence
+ double precision dvs_a(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvs_b(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvp_a(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvp_b(0:NK_20,0:NS_20,0:NS_20)
+ double precision spknt(NK_20+1)
+ double precision qq0(NK_20+1,NK_20+1)
+ double precision qq(3,NK_20+1,NK_20+1)
+ end type model_s20rts_variables
+
+ type (model_s20rts_variables) S20RTS_V
+! model_s20rts_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_20
+ do l=0,NS_20
+ read(10,*) S20RTS_V%dvs_a(k,l,0),(S20RTS_V%dvs_a(k,l,m),S20RTS_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_20
+ do l=0,12
+ read(10,*) S20RTS_V%dvp_a(k,l,0),(S20RTS_V%dvp_a(k,l,m),S20RTS_V%dvp_b(k,l,m),m=1,l)
+ enddo
+ do l=13,NS_20
+ S20RTS_V%dvp_a(k,l,0) = 0.0d0
+ do m=1,l
+ S20RTS_V%dvp_a(k,l,m) = 0.0d0
+ S20RTS_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 s20rts_splhsetup(S20RTS_V)
+
+ end subroutine read_model_s20rts
+
+!---------------------------
+
+ subroutine mantle_s20rts(radius,theta,phi,dvs,dvp,drho,S20RTS_V)
+
+ implicit none
+
+ include "constants.h"
+
+! model_s20rts_variables
+ type model_s20rts_variables
+ sequence
+ double precision dvs_a(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvs_b(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvp_a(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvp_b(0:NK_20,0:NS_20,0:NS_20)
+ double precision spknt(NK_20+1)
+ double precision qq0(NK_20+1,NK_20+1)
+ double precision qq(3,NK_20+1,NK_20+1)
+ end type model_s20rts_variables
+
+ type (model_s20rts_variables) S20RTS_V
+! model_s20rts_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 s20rts_rsple,radial_basis(0:NK_20)
+ double precision sint,cost,x(2*NS_20+1),dx(2*NS_20+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_20
+ radial_basis(k)=s20rts_rsple(1,NK_20+1,S20RTS_V%spknt(1),S20RTS_V%qq0(1,NK_20+1-k),S20RTS_V%qq(1,1,NK_20+1-k),xr)
+ enddo
+
+ do l=0,NS_20
+ 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_20
+ dvs_alm=dvs_alm+radial_basis(k)*S20RTS_V%dvs_a(k,l,0)
+ dvp_alm=dvp_alm+radial_basis(k)*S20RTS_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_20
+ dvs_alm=dvs_alm+radial_basis(k)*S20RTS_V%dvs_a(k,l,m)
+ dvp_alm=dvp_alm+radial_basis(k)*S20RTS_V%dvp_a(k,l,m)
+ dvs_blm=dvs_blm+radial_basis(k)*S20RTS_V%dvs_b(k,l,m)
+ dvp_blm=dvp_blm+radial_basis(k)*S20RTS_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_s20rts
+
+!----------------------------------
+
+ subroutine s20rts_splhsetup(S20RTS_V)!!!!!!!!!!!!!!(spknt,qq0,qq)
+
+ implicit none
+ include "constants.h"
+
+!!!!!!!!!!!!!!!!!!! double precision spknt(NK_20+1),qq0(NK_20+1,NK_20+1),qq(3,NK_20+1,NK_20+1)
+
+! model_s20rts_variables
+ type model_s20rts_variables
+ sequence
+ double precision dvs_a(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvs_b(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvp_a(0:NK_20,0:NS_20,0:NS_20)
+ double precision dvp_b(0:NK_20,0:NS_20,0:NS_20)
+ double precision spknt(NK_20+1)
+ double precision qq0(NK_20+1,NK_20+1)
+ double precision qq(3,NK_20+1,NK_20+1)
+ end type model_s20rts_variables
+
+ type (model_s20rts_variables) S20RTS_V
+! model_s20rts_variables
+
+
+ integer i,j
+ double precision qqwk(3,NK_20+1)
+
+ S20RTS_V%spknt(1) = -1.00000d0
+ S20RTS_V%spknt(2) = -0.78631d0
+ S20RTS_V%spknt(3) = -0.59207d0
+ S20RTS_V%spknt(4) = -0.41550d0
+ S20RTS_V%spknt(5) = -0.25499d0
+ S20RTS_V%spknt(6) = -0.10909d0
+ S20RTS_V%spknt(7) = 0.02353d0
+ S20RTS_V%spknt(8) = 0.14409d0
+ S20RTS_V%spknt(9) = 0.25367d0
+ S20RTS_V%spknt(10) = 0.35329d0
+ S20RTS_V%spknt(11) = 0.44384d0
+ S20RTS_V%spknt(12) = 0.52615d0
+ S20RTS_V%spknt(13) = 0.60097d0
+ S20RTS_V%spknt(14) = 0.66899d0
+ S20RTS_V%spknt(15) = 0.73081d0
+ S20RTS_V%spknt(16) = 0.78701d0
+ S20RTS_V%spknt(17) = 0.83810d0
+ S20RTS_V%spknt(18) = 0.88454d0
+ S20RTS_V%spknt(19) = 0.92675d0
+ S20RTS_V%spknt(20) = 0.96512d0
+ S20RTS_V%spknt(21) = 1.00000d0
+
+ do i=1,NK_20+1
+ do j=1,NK_20+1
+ if(i == j) then
+ S20RTS_V%qq0(j,i)=1.0d0
+ else
+ S20RTS_V%qq0(j,i)=0.0d0
+ endif
+ enddo
+ enddo
+ do i=1,NK_20+1
+ call s20rts_rspln(1,NK_20+1,S20RTS_V%spknt(1),S20RTS_V%qq0(1,i),S20RTS_V%qq(1,1,i),qqwk(1,1))
+ enddo
+
+ end subroutine s20rts_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 s20rts_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)
+ S20RTS_RSPLE=Y(I)+H*(Q(1,I)+H*(Q(2,I)+H*Q(3,I)))
+
+ end function s20rts_rsple
+
+!----------------------------------
+
+ subroutine s20rts_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 s20rts_rspln
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_s362ani.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_s362ani.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_s362ani.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_s362ani.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1990 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! S362ani
+!
+! A global shear-wave speed model developed by Kustowski et al. [2006].
+!
+! In this model, radial anisotropy is confined to the uppermost mantle.
+! The model (and the corresponding mesh) incorporate
+! tomography on the 650~km and 410~km discontinuities in the 1D reference model REF.
+!
+! s362wmani: A version of S362ANI with anisotropy allowed throughout the mantle.
+!
+! s362ani_prem: A version of S362ANI calculated using PREM as the 1D reference model
+!
+! s29ea: A global model with higher resolution in the upper mantle beneath Eurasia
+! calculated using REF as the 1D reference model.
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_s362ani_broadcast(myrank,THREE_D_MODEL,numker,numhpa,ihpa,&
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
+ xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+ integer THREE_D_MODEL
+
+! used for 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ 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=40) varstr(maxker)
+ character(len=80) refmdl
+
+ integer :: myrank
+ integer :: ier
+
+ ! master process
+ 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)
+
+
+ end subroutine model_s362ani_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ 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 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 splcon(xlat,xlon,nver,verlat,verlon,verrad,ncon,icon,con)
+
+ implicit none
+
+ integer :: ncon,nver
+
+!daniel: original
+! integer icon(1)
+!
+! real(kind=4) verlat(1)
+! real(kind=4) verlon(1)
+! real(kind=4) verrad(1)
+! real(kind=4) con(1)
+
+!daniel: avoiding out-of-bounds errors
+ real(kind=4) verlat(nver)
+ real(kind=4) verlon(nver)
+ real(kind=4) verrad(nver)
+
+ integer icon(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 :: iver
+ 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 model_s362ani_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
+
+! -------------------------------------
+ vsv3drel = 0.
+ vsh3drel = 0.
+
+ 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)
+!daniel
+! call splcon(y,x,numcof,xlaspl(1,ihpa), &
+! xlospl(1,ihpa),radspl(1,ihpa), &
+! nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
+
+ call splcon(y,x,numcof,xlaspl(1:numcof,ihpa), &
+ xlospl(1:numcof,ihpa),radspl(1:numcof,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 model_s362ani_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)
+
+!daniel
+! call splcon(y,x,numcof,xlaspl(1,ihpa), &
+! xlospl(1,ihpa),radspl(1,ihpa), &
+! nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
+
+ call splcon(y,x,numcof,xlaspl(1:numcof,ihpa), &
+ xlospl(1:numcof,ihpa),radspl(1:numcof,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) WK1(LMAX+1),WK2(LMAX+1),WK3(LMAX+1)
+ real(kind=4) XLAT,XLON
+ real(kind=4) Y(1) !! Y should go at least from 1 to fac(LMAX)
+
+ 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
+
+ ! index L goes from 0 to LMAX
+ L=IL1-1
+ !CALL legndr(THETA,L,L,WK1,WK2,WK3)
+ CALL legndr(THETA,L,L,WK1(1:L+1),WK2(1:L+1),WK3(1:L+1)) !! see legndr(): WK1,WK2,WK3 should go from 1 to L+1
+
+ FAC=(1.,0.)
+ DFAC=CEXP(CMPLX(0.,PHI))
+
+ ! loops over M
+ do IM=1,IL1
+ ! index IM goes maximum from 1 to LMAX+1
+ 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) !! X, XP, XCOSEC should go from 1 to M+1
+
+ 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
+
+ real(kind=4) :: X(M+1),XP(M+1),XCOSEC(M+1) !! X, XP, XCOSEC should go from 1 to M+1
+
+
+!!!!!! 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/src/model_s40rts.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_s40rts.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_s40rts.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_s40rts.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,520 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! S40rts
+!
+! 3D mantle model S40RTS [Ritsema et al., 2010]
+!
+! Note that S40RTS uses transversely isotropic PREM as a background
+! model, and that we use the PREM radial attenuation model when ATTENUATION is incorporated.
+!
+! reference:
+! J. Ritsema, A. Deuss, H.J. van Heijst and J.H. Woodhouse, 2010.
+! S40RTS: a degree-40 shear-velocity model for the mantle from new Rayleigh wave dispersion,
+! teleseismic traveltime and normal-mode splitting function measurements.
+! Geophys. J. Int., DOI: 10.1111/j.1365-246X.2010.04884.x
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_s40rts_broadcast(myrank,S40RTS_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+! model_s40rts_variables s40rts
+ type model_s40rts_variables
+ sequence
+ double precision dvs_a(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvs_b(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvp_a(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvp_b(0:NK_20,0:NS_40,0:NS_40)
+ double precision spknt(NK_20+1)
+ double precision qq0(NK_20+1,NK_20+1)
+ double precision qq(3,NK_20+1,NK_20+1)
+ end type model_s40rts_variables
+
+ type (model_s40rts_variables) S40RTS_V
+! model_s40rts_variables
+
+ integer :: myrank
+ integer :: ier
+ ! the variables read are declared and stored in structure S40RTS_V
+ if(myrank == 0) call read_model_s40rts(S40RTS_V)
+
+ ! broadcast the information read on the master to the nodes
+ call MPI_BCAST(S40RTS_V%dvs_a,(NK_20+1)*(NS_40+1)*(NS_40+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S40RTS_V%dvs_b,(NK_20+1)*(NS_40+1)*(NS_40+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S40RTS_V%dvp_a,(NK_20+1)*(NS_40+1)*(NS_40+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S40RTS_V%dvp_b,(NK_20+1)*(NS_40+1)*(NS_40+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S40RTS_V%spknt,NK_20+1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S40RTS_V%qq0,(NK_20+1)*(NK_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(S40RTS_V%qq,3*(NK_20+1)*(NK_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ end subroutine model_s40rts_broadcast
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_model_s40rts(S40RTS_V)
+
+ implicit none
+
+ include "constants.h"
+
+! model_s40rts_variables
+ type model_s40rts_variables
+ sequence
+ double precision dvs_a(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvs_b(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvp_a(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvp_b(0:NK_20,0:NS_40,0:NS_40)
+ double precision spknt(NK_20+1)
+ double precision qq0(NK_20+1,NK_20+1)
+ double precision qq(3,NK_20+1,NK_20+1)
+ end type model_s40rts_variables
+
+ type (model_s40rts_variables) S40RTS_V
+! model_s40rts_variables
+
+ integer k,l,m
+
+ character(len=150) S40RTS, P12
+ call get_value_string(S40RTS, 'model.S40RTS', 'DATA/s40rts/S40RTS.dat')
+ call get_value_string(P12, 'model.P12', 'DATA/s20rts/P12.dat') !model P12 is in s20rts data directory
+
+! S40RTS degree 20 S model from Ritsema
+ open(unit=10,file=S40RTS,status='old',action='read')
+ do k=0,NK_20
+ do l=0,NS_40
+ read(10,*) S40RTS_V%dvs_a(k,l,0),(S40RTS_V%dvs_a(k,l,m),S40RTS_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_20
+ do l=0,12
+ read(10,*) S40RTS_V%dvp_a(k,l,0),(S40RTS_V%dvp_a(k,l,m),S40RTS_V%dvp_b(k,l,m),m=1,l)
+ enddo
+ do l=13,NS_40
+ S40RTS_V%dvp_a(k,l,0) = 0.0d0
+ do m=1,l
+ S40RTS_V%dvp_a(k,l,m) = 0.0d0
+ S40RTS_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 s40rts_splhsetup(S40RTS_V)
+
+ end subroutine read_model_s40rts
+
+!---------------------------
+
+ subroutine mantle_s40rts(radius,theta,phi,dvs,dvp,drho,S40RTS_V)
+
+ implicit none
+
+ include "constants.h"
+
+! model_s40rts_variables
+ type model_s40rts_variables
+ sequence
+ double precision dvs_a(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvs_b(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvp_a(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvp_b(0:NK_20,0:NS_40,0:NS_40)
+ double precision spknt(NK_20+1)
+ double precision qq0(NK_20+1,NK_20+1)
+ double precision qq(3,NK_20+1,NK_20+1)
+ end type model_s40rts_variables
+
+ type (model_s40rts_variables) S40RTS_V
+! model_s40rts_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 s40rts_rsple,radial_basis(0:NK_20)
+ double precision sint,cost,x(2*NS_40+1),dx(2*NS_40+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)
+ if(xr > 1.0) print *,'xr > 1.0'
+ if(xr < -1.0) print *,'xr < -1.0'
+ do k=0,NK_20
+ radial_basis(k)=s40rts_rsple(1,NK_20+1,S40RTS_V%spknt(1),S40RTS_V%qq0(1,NK_20+1-k),S40RTS_V%qq(1,1,NK_20+1-k),xr)
+ enddo
+
+ do l=0,NS_40
+ 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_20
+ dvs_alm=dvs_alm+radial_basis(k)*S40RTS_V%dvs_a(k,l,0)
+ dvp_alm=dvp_alm+radial_basis(k)*S40RTS_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_20
+ dvs_alm=dvs_alm+radial_basis(k)*S40RTS_V%dvs_a(k,l,m)
+ dvp_alm=dvp_alm+radial_basis(k)*S40RTS_V%dvp_a(k,l,m)
+ dvs_blm=dvs_blm+radial_basis(k)*S40RTS_V%dvs_b(k,l,m)
+ dvp_blm=dvp_blm+radial_basis(k)*S40RTS_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_s40rts
+
+!----------------------------------
+
+ subroutine s40rts_splhsetup(S40RTS_V)!!!!!!!!!!!!!!(spknt,qq0,qq)
+
+ implicit none
+ include "constants.h"
+
+!!!!!!!!!!!!!!!!!!! double precision spknt(NK_20+1),qq0(NK_20+1,NK_20+1),qq(3,NK_20+1,NK_20+1)
+
+! model_s40rts_variables
+ type model_s40rts_variables
+ sequence
+ double precision dvs_a(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvs_b(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvp_a(0:NK_20,0:NS_40,0:NS_40)
+ double precision dvp_b(0:NK_20,0:NS_40,0:NS_40)
+ double precision spknt(NK_20+1)
+ double precision qq0(NK_20+1,NK_20+1)
+ double precision qq(3,NK_20+1,NK_20+1)
+ end type model_s40rts_variables
+
+ type (model_s40rts_variables) S40RTS_V
+! model_s40rts_variables
+
+
+ integer i,j
+ double precision qqwk(3,NK_20+1)
+
+ S40RTS_V%spknt(1) = -1.00000d0
+ S40RTS_V%spknt(2) = -0.78631d0
+ S40RTS_V%spknt(3) = -0.59207d0
+ S40RTS_V%spknt(4) = -0.41550d0
+ S40RTS_V%spknt(5) = -0.25499d0
+ S40RTS_V%spknt(6) = -0.10909d0
+ S40RTS_V%spknt(7) = 0.02353d0
+ S40RTS_V%spknt(8) = 0.14409d0
+ S40RTS_V%spknt(9) = 0.25367d0
+ S40RTS_V%spknt(10) = 0.35329d0
+ S40RTS_V%spknt(11) = 0.44384d0
+ S40RTS_V%spknt(12) = 0.52615d0
+ S40RTS_V%spknt(13) = 0.60097d0
+ S40RTS_V%spknt(14) = 0.66899d0
+ S40RTS_V%spknt(15) = 0.73081d0
+ S40RTS_V%spknt(16) = 0.78701d0
+ S40RTS_V%spknt(17) = 0.83810d0
+ S40RTS_V%spknt(18) = 0.88454d0
+ S40RTS_V%spknt(19) = 0.92675d0
+ S40RTS_V%spknt(20) = 0.96512d0
+ S40RTS_V%spknt(21) = 1.00000d0
+
+ do i=1,NK_20+1
+ do j=1,NK_20+1
+ if(i == j) then
+ S40RTS_V%qq0(j,i)=1.0d0
+ else
+ S40RTS_V%qq0(j,i)=0.0d0
+ endif
+ enddo
+ enddo
+ do i=1,NK_20+1
+ call s40rts_rspln(1,NK_20+1,S40RTS_V%spknt(1),S40RTS_V%qq0(1,i),S40RTS_V%qq(1,1,i),qqwk(1,1))
+ enddo
+
+ end subroutine s40rts_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 s40rts_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)
+ S40RTS_RSPLE=Y(I)+H*(Q(1,I)+H*(Q(2,I)+H*Q(3,I)))
+
+ end function s40rts_rsple
+
+!----------------------------------
+
+ subroutine s40rts_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 s40rts_rspln
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_sea1d.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea1d.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_sea1d.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_sea1d.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1182 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! SEA 1D
+!
+! used as 1-D reference model for SEA 99, Vs model by Lebedev & Nolet 2003
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_sea1d_broadcast(CRUSTAL, SEA1DM_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+
+ ! model_sea1d_variables
+ type model_sea1d_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 model_sea1d_variables
+
+ type (model_sea1d_variables) SEA1DM_V
+ ! model_sea1d_variables
+
+ logical :: CRUSTAL
+
+ ! all processes will define same parameters
+ call define_model_sea1d(CRUSTAL, SEA1DM_V)
+
+ end subroutine model_sea1d_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_sea1d(x,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! model_sea1d_variables
+ type model_sea1d_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 model_sea1d_variables
+
+ type (model_sea1d_variables) SEA1DM_V
+! model_sea1d_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"
+
+! model_sea1d_variables
+ type model_sea1d_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 model_sea1d_variables
+
+ type (model_sea1d_variables) SEA1DM_V
+! model_sea1d_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 (SUPPRESS_CRUSTAL_MESH .or. 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/src/model_sea99_s.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea99_s.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_sea99_s.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_sea99_s.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,252 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! SEA 99 model
+!
+! contains relative Vs anomalies dVs/Vs from
+! SV-velocity model for SE Asia - W Pacific.
+!
+! defined for:
+! -20.00 45.00 -- min, max latitude
+! 95.00 160.00 -- min, max longitude
+! and depths between 6 km to 860 km
+!
+! computed by Lebedev and Nolet in 1999, to come out in JGR in 2003.
+! reference period: 50 s.
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_sea99_s_broadcast(myrank,SEA99M_V)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+ ! model_sea99_s_variables
+ type model_sea99_s_variables
+ sequence
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_sea99_s_variables
+
+ type (model_sea99_s_variables) SEA99M_V
+ ! model_sea99_s_variables
+
+ integer :: myrank
+ integer :: ier
+
+ 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)
+
+ end subroutine model_sea99_s_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_sea99_s_model(SEA99M_V)
+
+ implicit none
+
+ include "constants.h"
+
+ ! model_sea99_s_variables
+ type model_sea99_s_variables
+ sequence
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_sea99_s_variables
+
+ type (model_sea99_s_variables) SEA99M_V
+ ! model_sea99_s_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 /= nint((SEA99M_V%alatmax-SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg)+1) then
+ stop 'alatmin,alatmax,sea99_nlat'
+ endif
+ if (SEA99M_V%sea99_nlon /= 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 model_sea99_s(radius,theta,phi,dvs,SEA99M_V)
+
+! returns Vs perturbation (dvs) for given position r/theta/phi
+
+ implicit none
+
+ include "constants.h"
+
+ ! model_sea99_s_variables
+ type model_sea99_s_variables
+ sequence
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ integer :: dummy_pad ! padding 4 bytes to align the structure
+ end type model_sea99_s_variables
+
+ type (model_sea99_s_variables) SEA99M_V
+ ! model_sea99_s_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)
+
+ ! initializes
+ dvs = 0.d0
+
+ id1 = 0
+ xd1 = 0
+
+ !----------------------- depth in the model ------------------
+ dep=R_EARTH_KM*(R_UNIT_SPHERE - radius)
+ 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))
+ exit
+ endif
+ enddo
+ endif
+
+ !----------------------- value at a point ---------------------
+ !----- approximate interpolation, OK for the (dense) 1-degree sampling ------
+
+ ! latitude / longitude in degree
+ pla = 90.0d0 - theta/DEGREES_TO_RADIANS
+ plo = phi/DEGREES_TO_RADIANS
+
+ ! model defined for:
+ ! -20.00 45.00 -- min, max latitude
+ ! 95.00 160.00 -- min, max longitude
+ ! checks range
+ if( pla < SEA99M_V%alatmin .or. pla > SEA99M_V%alatmax &
+ .or. plo < SEA99M_V%alonmin .or. plo > SEA99M_V%alonmax ) return
+
+ ! array indices
+ 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
+
+ ! checks perturbation
+ if(dvs > 1.d0) dvs = 0.0d0
+
+ end subroutine model_sea99_s
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_topo_bathy.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/model_topo_bathy.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_topo_bathy.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/model_topo_bathy.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,195 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!--------------------------------------------------------------------------------------------------
+! ETOPO
+!
+! Global Gridded Elevation Data
+!
+! by default (constants.h), it uses a smoothed ETOPO 4 dataset
+!--------------------------------------------------------------------------------------------------
+
+
+ subroutine model_topo_bathy_broadcast(myrank,ibathy_topo)
+
+! standard routine to setup model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+ ! bathymetry and topography: use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ integer :: myrank
+ integer :: ier
+
+ 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)
+
+ end subroutine model_topo_bathy_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ 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,ier
+
+ call get_value_string(topo_bathy_file, 'model.topoBathy.PATHNAME_TOPO_FILE', PATHNAME_TOPO_FILE)
+
+ ! reads in topography values from file
+ open(unit=13,file=trim(topo_bathy_file),status='old',action='read',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening:',trim(topo_bathy_file)
+ call exit_mpi(0,'error opening topography data file')
+ endif
+ ! reads in topography array
+ do itopo_y=1,NY_BATHY
+ do itopo_x=1,NX_BATHY
+ read(13,*) ibathy_topo(itopo_x,itopo_y)
+ enddo
+ enddo
+ close(13)
+
+
+ ! note: we check the limits after reading in the data. this seems to perform sligthly faster
+ ! however, reading ETOPO1.xyz will take ~ 2m 1.2s for a single process
+
+ ! imposes limits
+ if( USE_MAXIMUM_HEIGHT_TOPO .or. USE_MAXIMUM_DEPTH_OCEANS ) then
+ do itopo_y=1,NY_BATHY
+ do itopo_x=1,NX_BATHY
+
+ ! 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
+
+ endif
+
+ end subroutine read_topo_bathy_file
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ 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
+ double precision:: lon_corner,lat_corner,ratio_lon,ratio_lat
+
+ 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
+
+! Use bilinear interpolation rather nearest point interpolation
+! convert integer value to double precision
+ ! value = dble(ibathy_topo(iel1,iadd1))
+
+ lon_corner=iel1*samples_per_degree_topo
+ lat_corner=90.d0-iadd1*samples_per_degree_topo
+
+ ratio_lon = (xlo-lon_corner)/samples_per_degree_topo
+ ratio_lat = (xlat-lat_corner)/samples_per_degree_topo
+
+ if(ratio_lon<0.0) ratio_lon=0.0
+ if(ratio_lon>1.0) ratio_lon=1.0
+ if(ratio_lat<0.0) ratio_lat=0.0
+ if(ratio_lat>1.0) ratio_lat=1.0
+
+! convert integer value to double precision
+ if( iadd1 <= NY_BATHY-1 .and. iel1 <= NX_BATHY-1 ) then
+ ! interpolates for points within boundaries
+ value = dble(ibathy_topo(iel1,iadd1))*(1-ratio_lon)*(1.-ratio_lat) &
+ + dble(ibathy_topo(iel1+1,iadd1))*ratio_lon*(1.-ratio_lat) &
+ + dble(ibathy_topo(iel1+1,iadd1+1))*ratio_lon*ratio_lat &
+ + dble(ibathy_topo(iel1,iadd1+1))*(1.-ratio_lon)*ratio_lat
+ else if( iadd1 <= NY_BATHY-1 .and. iel1 == NX_BATHY ) then
+ ! interpolates for points on longitude border
+ value = dble(ibathy_topo(iel1,iadd1))*(1-ratio_lon)*(1.-ratio_lat) &
+ + dble(ibathy_topo(1,iadd1))*ratio_lon*(1.-ratio_lat) &
+ + dble(ibathy_topo(1,iadd1+1))*ratio_lon*ratio_lat &
+ + dble(ibathy_topo(iel1,iadd1+1))*(1.-ratio_lon)*ratio_lat
+ else
+ ! for points on latitude boundaries
+ value = dble(ibathy_topo(iel1,iadd1))
+ endif
+
+ end subroutine get_topo_bathy
+
+! -------------------------------------------
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/moho_stretching.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/moho_stretching.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/moho_stretching.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/moho_stretching.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,907 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine moho_stretching_honor_crust(myrank,xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
+ R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
+
+! stretching the moho according to the crust 2.0
+! input: myrank, xelm, yelm, zelm, RMOHO_FICTITIOUS_IN_MESHER R220,RMIDDLE_CRUST, CM_V
+! Dec, 30, 2009
+
+ implicit none
+
+ include "constants.h"
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+ double precision R220,RMIDDLE_CRUST
+ double precision RMOHO_FICTITIOUS_IN_MESHER
+ integer :: myrank
+ logical :: elem_in_crust,elem_in_mantle
+
+ ! local parameters
+ integer:: ia,count_crust,count_mantle
+ double precision:: r,theta,phi,lat,lon
+ double precision:: vpc,vsc,rhoc,moho,elevation,gamma
+ logical:: found_crust
+
+ double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
+ double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
+ !double precision :: stretch_factor
+ double precision :: x,y,z
+ double precision :: R_moho,R_middlecrust
+
+ ! radii for stretching criteria
+ R_moho = RMOHO_FICTITIOUS_IN_MESHER/R_EARTH
+ R_middlecrust = RMIDDLE_CRUST/R_EARTH
+
+ ! loops over element's anchor points
+ count_crust = 0
+ count_mantle = 0
+ do ia = 1,NGNOD
+ x = xelm(ia)
+ y = yelm(ia)
+ z = zelm(ia)
+
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+ call reduce(theta,phi)
+
+ lat = 90.d0 - theta * RADIANS_TO_DEGREES
+ lon = phi * RADIANS_TO_DEGREES
+ if( lon > 180.d0 ) lon = lon - 360.0d0
+
+ ! initializes
+ moho = 0.d0
+
+ ! gets smoothed moho depth
+ call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
+
+ ! checks moho depth
+ if( abs(moho) < TINYVAL ) call exit_mpi(myrank,'error moho depth to honor')
+
+ moho = ONE - moho
+
+ ! checks if moho will be honored by elements
+ !
+ ! note: we will honor the moho only, if the moho depth is below R_moho (~35km)
+ ! or above R_middlecrust (~15km). otherwise, the moho will be "interpolated"
+ ! within the element
+ if (moho < R_moho ) then
+ ! actual moho below fictitious moho
+ ! elements in second layer will stretch down to honor moho topography
+
+ elevation = moho - R_moho
+
+ if ( r >= R_moho ) then
+ ! point above fictitious moho
+ ! gamma ranges from 0 (point at surface) to 1 (point at fictitious moho depth)
+ gamma = (( R_UNIT_SPHERE - r )/( R_UNIT_SPHERE - R_moho ))
+ else
+ ! point below fictitious moho
+ ! gamma ranges from 0 (point at R220) to 1 (point at fictitious moho depth)
+ gamma = (( r - R220/R_EARTH)/( R_moho - R220/R_EARTH))
+
+ ! since not all GLL points are exactlly at R220, use a small
+ ! tolerance for R220 detection, fix R220
+ if (abs(gamma) < SMALLVAL) then
+ gamma = 0.0d0
+ end if
+ end if
+
+ if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
+ call exit_MPI(myrank,'incorrect value of gamma for moho from crust 2.0')
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+
+ else if ( moho > R_middlecrust ) then
+ ! moho above middle crust
+ ! elements in first layer will squeeze into crust above moho
+
+ elevation = moho - R_middlecrust
+
+ if ( r > R_middlecrust ) then
+ ! point above middle crust
+ ! gamma ranges from 0 (point at surface) to 1 (point at middle crust depth)
+ gamma = (R_UNIT_SPHERE-r)/(R_UNIT_SPHERE - R_middlecrust )
+ else
+ ! point below middle crust
+ ! gamma ranges from 0 (point at R220) to 1 (point at middle crust depth)
+ gamma = (r - R220/R_EARTH)/( R_middlecrust - R220/R_EARTH )
+
+ ! since not all GLL points are exactlly at R220, use a small
+ ! tolerance for R220 detection, fix R220
+ if (abs(gamma) < SMALLVAL) then
+ gamma = 0.0d0
+ end if
+ end if
+
+ if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
+ call exit_MPI(myrank,'incorrect value of gamma for moho from crust 2.0')
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+
+ end if
+
+ ! counts corners in above moho
+ ! note: uses a small tolerance
+ if ( r >= 0.9999d0*moho ) then
+ count_crust = count_crust + 1
+ endif
+ ! counts corners below moho
+ ! again within a small tolerance
+ if ( r <= 1.0001d0*moho ) then
+ count_mantle = count_mantle + 1
+ endif
+
+ end do
+
+ ! sets flag when all corners are above moho
+ if( count_crust == NGNOD) then
+ elem_in_crust = .true.
+ end if
+ ! sets flag when all corners are below moho
+ if( count_mantle == NGNOD) then
+ elem_in_mantle = .true.
+ end if
+
+ ! small stretch check: stretching should affect only points above R220
+ if( r*R_EARTH < R220 ) then
+ print*,'error moho stretching: ',r*R_EARTH,R220,moho*R_EARTH
+ call exit_mpi(myrank,'incorrect moho stretching')
+ endif
+
+ end subroutine moho_stretching_honor_crust
+
+
+!
+!------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine moho_stretching_honor_crust_reg(myrank, &
+ xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
+ R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
+
+! regional routine: for REGIONAL_MOHO_MESH adaptations
+!
+! uses a 3-layer crust region
+!
+! stretching the moho according to the crust 2.0
+! input: myrank, xelm, yelm, zelm, RMOHO_FICTITIOUS_IN_MESHER R220,RMIDDLE_CRUST, CM_V
+! Dec, 30, 2009
+
+ implicit none
+
+ include "constants.h"
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+ double precision R220,RMIDDLE_CRUST
+ double precision RMOHO_FICTITIOUS_IN_MESHER
+ integer :: myrank
+ logical :: elem_in_crust,elem_in_mantle
+
+ ! local parameters
+ integer:: ia,count_crust,count_mantle
+ double precision:: r,theta,phi,lat,lon
+ double precision:: vpc,vsc,rhoc,moho
+ logical:: found_crust
+
+ double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
+ double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
+ double precision :: x,y,z
+
+ ! loops over element's anchor points
+ count_crust = 0
+ count_mantle = 0
+ do ia = 1,NGNOD
+
+ ! anchor point location
+ x = xelm(ia)
+ y = yelm(ia)
+ z = zelm(ia)
+
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+ call reduce(theta,phi)
+
+ lat = 90.d0 - theta * RADIANS_TO_DEGREES
+ lon = phi * RADIANS_TO_DEGREES
+ if( lon > 180.d0 ) lon = lon - 360.0d0
+
+ ! initializes
+ moho = 0.d0
+
+ ! gets smoothed moho depth
+ call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
+
+ ! checks moho depth
+ if( abs(moho) < TINYVAL ) call exit_mpi(myrank,'error moho depth to honor')
+
+ moho = ONE - moho
+
+ ! checks if moho will be honored by elements
+ !
+ ! note: we will honor the moho, if the moho depth is
+ ! - above 15km
+ ! - between 25km and 45km
+ ! - below 60 km (in HONOR_DEEP_MOHO case)
+ ! otherwise, the moho will be "interpolated" within the element
+ if( HONOR_DEEP_MOHO) then
+ call stretch_deep_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
+ RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
+ else
+ call stretch_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
+ RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
+ endif
+
+ ! counts corners in above moho
+ ! note: uses a small tolerance
+ if ( r >= 0.9999d0*moho ) then
+ count_crust = count_crust + 1
+ endif
+ ! counts corners below moho
+ ! again within a small tolerance
+ if ( r <= 1.0001d0*moho ) then
+ count_mantle = count_mantle + 1
+ endif
+
+ end do
+
+ ! sets flag when all corners are above moho
+ if( count_crust == NGNOD) then
+ elem_in_crust = .true.
+ end if
+ ! sets flag when all corners are below moho
+ if( count_mantle == NGNOD) then
+ elem_in_mantle = .true.
+ end if
+
+ ! small stretch check: stretching should affect only points above R220
+ if( r*R_EARTH < R220 ) then
+ print*,'error moho stretching: ',r*R_EARTH,R220,moho*R_EARTH
+ call exit_mpi(myrank,'incorrect moho stretching')
+ endif
+
+ end subroutine moho_stretching_honor_crust_reg
+
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine stretch_deep_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
+ RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
+
+! honors deep moho (below 60 km), otherwise keeps the mesh boundary at r60 fixed
+
+ implicit none
+
+ include "constants.h"
+
+ integer ia
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision :: x,y,z
+
+ double precision :: r,moho,R220
+ double precision :: RMIDDLE_CRUST
+ double precision :: RMOHO_FICTITIOUS_IN_MESHER
+
+ ! local parameters
+ double precision :: elevation,gamma
+ ! radii for stretching criteria
+ double precision,parameter :: R15=6356000.d0/R_EARTH
+ double precision,parameter :: R25=6346000.d0/R_EARTH
+ double precision,parameter :: R30=6341000.d0/R_EARTH
+ double precision,parameter :: R35=6336000.d0/R_EARTH
+ double precision,parameter :: R40=6331000.d0/R_EARTH
+ double precision,parameter :: R45=6326000.d0/R_EARTH
+ double precision,parameter :: R50=6321000.d0/R_EARTH
+ double precision,parameter :: R55=6316000.d0/R_EARTH
+ double precision,parameter :: R60=6311000.d0/R_EARTH
+
+ ! checks moho position: supposed to be at 60 km
+ if( RMOHO_STRETCH_ADJUSTEMENT /= -20000.d0 ) &
+ stop 'wrong moho stretch adjustement for stretch_deep_moho'
+ if( RMOHO_FICTITIOUS_IN_MESHER/R_EARTH /= R60 ) &
+ stop 'wrong moho depth '
+ ! checks middle crust position: supposed to be bottom of first layer at 15 km
+ if( RMIDDLE_CRUST/R_EARTH /= R15 ) &
+ stop 'wrong middle crust depth'
+
+ ! stretches mesh by moving point coordinates
+ if ( moho < R25 .and. moho > R45 ) then
+ ! moho between r25 and r45
+
+ ! stretches mesh at r35 to moho depth
+ elevation = moho - R35
+ if ( r >=R35.and.r<R15) then
+ gamma=((R15-r)/(R15-R35))
+ else if ( r < R35 .and. r > R60 ) then
+ gamma = (( r - R60)/( R35 - R60)) ! keeps r60 fixed
+ if (abs(gamma)<SMALLVAL) then
+ gamma=0.0d0
+ end if
+ else
+ gamma=0.0d0
+ end if
+ if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
+ stop 'incorrect value of gamma for moho from crust 2.0'
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+
+ else if ( moho < R45 ) then
+ ! moho below r45
+
+ ! moves mesh at r35 down to r45
+ elevation = R45 - R35
+ if ( r>= R35.and.r<R15) then
+ gamma=((R15-r)/(R15-R35)) ! moves r35 down to r45
+ else if ( r<R35 .and. r>R60 ) then
+ gamma=((r-R60)/(R35-R60)) ! keeps r60 fixed
+ if (abs(gamma)<SMALLVAL) then
+ gamma=0.0d0
+ end if
+ else
+ gamma=0.0d0
+ end if
+ if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
+ stop 'incorrect value of gamma for moho from crust 2.0'
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+
+ ! add deep moho here
+ if ( moho < R60) then
+ ! moho below r60
+
+ ! stretches mesh at r60 to moho
+ elevation = moho - R60
+ if ( r <R45.and. r >= R60) then
+ gamma=(R45-r)/(R45-R60)
+ else if (r<R60) then
+ gamma=(r-R220/R_EARTH)/(R60-R220/R_EARTH)
+ if (abs(gamma)<SMALLVAL) then
+ gamma=0.0d0
+ end if
+ else
+ gamma=0.0d0
+ end if
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+ end if
+
+ else if (moho > R25) then
+ ! moho above r25
+
+ ! moves mesh at r35 up to r25
+ elevation = R25-R35
+ if (r>=R35.and.r<R15) then
+ gamma=((R15-r)/(R15-R35)) ! stretches r35 up to r25
+ else if (r<R35 .and. r>R60 ) then
+ gamma=(r-R60)/(R35-R60) ! keeps r60 fixed
+ if (abs(gamma)<SMALLVAL) then
+ gamma=0.0d0
+ end if
+ else
+ gamma=0.0d0
+ end if
+ if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
+ stop 'incorrect value of gamma for moho from crust 2.0'
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+
+ ! add shallow moho here
+ if ( moho > R15 ) then
+ ! moho above r15
+
+ ! stretches mesh at r15 to moho depth
+ elevation = moho-R15
+ if (r>=R15) then
+ gamma=(R_UNIT_SPHERE-r)/(R_UNIT_SPHERE-R15)
+ else if (r<R15.and.R>R25) then
+ gamma=(r-R25)/(R15-R25) ! keeps mesh at r25 fixed
+ if (abs(gamma)<SMALLVAL) then
+ gamma=0.0d0
+ end if
+ else
+ gamma=0.0d0
+ end if
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+ end if
+ end if
+
+ end subroutine stretch_deep_moho
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine stretch_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
+ RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
+
+! honors shallow and middle depth moho, deep moho will be interpolated within elements
+! mesh will get stretched down to r220
+
+ implicit none
+
+ include "constants.h"
+
+ integer ia
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision :: r,moho,R220
+ double precision :: x,y,z
+ double precision :: RMIDDLE_CRUST
+ double precision :: RMOHO_FICTITIOUS_IN_MESHER
+
+ ! local parameters
+ double precision :: elevation,gamma
+ ! radii for stretching criteria
+ double precision,parameter :: R15=6356000.d0/R_EARTH
+ double precision,parameter :: R25=6346000.d0/R_EARTH
+ double precision,parameter :: R30=6341000.d0/R_EARTH
+ double precision,parameter :: R35=6336000.d0/R_EARTH
+ double precision,parameter :: R40=6331000.d0/R_EARTH
+ double precision,parameter :: R45=6326000.d0/R_EARTH
+ double precision,parameter :: R50=6321000.d0/R_EARTH
+ double precision,parameter :: R55=6316000.d0/R_EARTH
+ double precision,parameter :: R60=6311000.d0/R_EARTH
+
+ ! checks moho position: supposed to be at 55 km
+ if( RMOHO_STRETCH_ADJUSTEMENT /= -15000.d0 ) &
+ stop 'wrong moho stretch adjustement for stretch_deep_moho'
+ if( RMOHO_FICTITIOUS_IN_MESHER/R_EARTH /= R55 ) &
+ stop 'wrong moho depth '
+ ! checks middle crust position: supposed to be bottom of first layer at 15 km
+ if( RMIDDLE_CRUST/R_EARTH /= R15 ) &
+ stop 'wrong middle crust depth'
+
+ ! moho between 25km and 45 km
+ if ( moho < R25 .and. moho > R45 ) then
+
+ elevation = moho - R35
+ if ( r >=R35.and.r<R15) then
+ gamma=((R15-r)/(R15-R35))
+ else if ( r<R35.and.r>R220/R_EARTH) then
+ gamma = ((r-R220/R_EARTH)/(R35-R220/R_EARTH))
+ if (abs(gamma)<SMALLVAL) then
+ gamma=0.0d0
+ end if
+ else
+ gamma=0.0d0
+ end if
+ if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
+ stop 'incorrect value of gamma for moho from crust 2.0'
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+
+ else if ( moho < R45 ) then
+ ! moho below 45 km
+
+ ! moves mesh at r35 down to r45
+ elevation = R45 - R35
+ if ( r>= R35.and.r<R15) then
+ gamma=((R15-r)/(R15-R35))
+ else if ( r<R35.and.r>R220/R_EARTH) then
+ gamma=((r-R220/R_EARTH)/(R35-R220/R_EARTH))
+ if (abs(gamma)<SMALLVAL) then
+ gamma=0.0d0
+ end if
+ else
+ gamma=0.0d0
+ end if
+ if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
+ stop 'incorrect value of gamma for moho from crust 2.0'
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+
+ else if (moho > R25) then
+ ! moho above 25km
+
+ ! moves mesh at r35 up to r25
+ elevation = R25-R35
+ if (r>=R35.and.r<R15) then
+ gamma=((R15-r)/(R15-R35))
+ else if (r<R35.and.r>R220/R_EARTH) then
+ gamma=(r-R220/R_EARTH)/(R35-R220/R_EARTH)
+ if (abs(gamma)<SMALLVAL) then
+ gamma=0.0d0
+ end if
+ else
+ gamma=0.0d0
+ end if
+ if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
+ stop 'incorrect value of gamma for moho from crust 2.0'
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+
+ ! add shallow moho here
+ if ( moho >R15) then
+ elevation = moho-R15
+ if (r>=R15) then
+ gamma=(R_UNIT_SPHERE-r)/(R_UNIT_SPHERE-R15)
+ else if (r<R15.and.R>R25) then
+ gamma=(r-R25)/(R15-R25)
+ if (abs(gamma)<SMALLVAL) then
+ gamma=0.0d0
+ end if
+ else
+ gamma=0.0d0
+ end if
+
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+ end if
+ endif
+
+ end subroutine stretch_moho
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+
+! moves a point to a new location defined by gamma,elevation and r
+ implicit none
+
+ include "constants.h"
+
+ integer ia
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision :: x,y,z
+
+ double precision :: r,elevation,gamma
+
+ ! local parameters
+ double precision :: stretch_factor
+
+ ! stretch factor
+ ! offset will be gamma * elevation
+ ! scaling cartesian coordinates xyz rather than spherical r/theta/phi involves division of offset by r
+ stretch_factor = ONE + gamma * elevation/r
+
+ ! new point location
+ x = x * stretch_factor
+ y = y * stretch_factor
+ z = z * stretch_factor
+
+ ! stores new point location
+ xelm(ia) = x
+ yelm(ia) = y
+ zelm(ia) = z
+
+ ! new radius
+ r = dsqrt(xelm(ia)*xelm(ia) + yelm(ia)*yelm(ia) + zelm(ia)*zelm(ia))
+
+ end subroutine move_point
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! obsolete...
+!
+! 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/src/netlib_specfun_erf.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/netlib_specfun_erf.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/netlib_specfun_erf.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/netlib_specfun_erf.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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/src/noise_tomography.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/noise_tomography.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/noise_tomography.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/noise_tomography.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,653 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! =============================================================================================================
+! =============================================================================================================
+! =============================================================================================================
+
+! subroutine for NOISE TOMOGRAPHY
+! chracterize noise statistics
+! for a given point (xcoord,ycoord,zcoord), specify the noise direction "normal_x/y/z_noise"
+! and noise distribution "mask_noise"
+! USERS need to modify this subroutine for their own noise characteristics
+ subroutine noise_distribution_direction(xcoord_in,ycoord_in,zcoord_in, &
+ normal_x_noise_out,normal_y_noise_out,normal_z_noise_out, &
+ mask_noise_out)
+ implicit none
+ include "constants.h"
+ ! input parameters
+ real(kind=CUSTOM_REAL) :: xcoord_in,ycoord_in,zcoord_in
+ ! output parameters
+ real(kind=CUSTOM_REAL) :: normal_x_noise_out,normal_y_noise_out,normal_z_noise_out,mask_noise_out
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: xcoord,ycoord,zcoord
+
+
+ ! coordinates "x/y/zcoord_in" actually contain r theta phi, therefore convert back to x y z
+ call rthetaphi_2_xyz(xcoord,ycoord,zcoord, xcoord_in,ycoord_in,zcoord_in)
+ ! NOTE that all coordinates are non-dimensionalized in GLOBAL package!
+ ! USERS are free to choose which set to use,
+ ! either "r theta phi" (xcoord_in,ycoord_in,zcoord_in)
+ ! or "x y z" (xcoord,ycoord,zcoord)
+
+ !*****************************************************************************************************************
+ !******************************** change your noise characteristics below ****************************************
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! noise direction
+ ! here, the noise is assumed to be vertical
+ normal_x_noise_out = xcoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
+ normal_y_noise_out = ycoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
+ normal_z_noise_out = zcoord / sqrt(xcoord**2 + ycoord**2 + zcoord**2)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! noise distribution
+ ! here, the noise is assumed to be uniform
+ mask_noise_out = 1.0
+ !******************************** change your noise characteristics above ****************************************
+ !*****************************************************************************************************************
+
+ end subroutine noise_distribution_direction
+
+! =============================================================================================================
+! =============================================================================================================
+! =============================================================================================================
+
+! subroutine for NOISE TOMOGRAPHY
+! read parameters
+ subroutine read_parameters_noise(myrank,nrec,NSTEP,nmovie_points, &
+ islice_selected_rec,xi_receiver,eta_receiver,gamma_receiver,nu, &
+ noise_sourcearray,xigll,yigll,zigll,nspec_top, &
+ NIT, ibool_crust_mantle, ibelm_top_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ irec_master_noise,normal_x_noise,normal_y_noise,normal_z_noise,mask_noise)
+ implicit none
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+ include 'mpif.h'
+ include "precision.h"
+ ! input parameters
+ integer :: myrank, nrec, NSTEP, nmovie_points, nspec_top, NIT
+ integer, dimension(nrec) :: islice_selected_rec
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+ double precision, dimension(NDIM,NDIM,nrec) :: nu
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+ ! output parameters
+ integer :: irec_master_noise
+ real(kind=CUSTOM_REAL) :: noise_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NSTEP)
+ real(kind=CUSTOM_REAL), dimension(nmovie_points) :: normal_x_noise,normal_y_noise,normal_z_noise,mask_noise
+ ! local parameters
+ integer :: ipoin, ispec2D, ispec, i, j, k, iglob, ios, ier
+ real(kind=CUSTOM_REAL) :: normal_x_noise_out,normal_y_noise_out,normal_z_noise_out,mask_noise_out
+ character(len=150) :: filename
+ real(kind=CUSTOM_REAL), dimension(nmovie_points) :: &
+ store_val_x,store_val_y,store_val_z, store_val_ux,store_val_uy,store_val_uz
+ real(kind=CUSTOM_REAL), dimension(nmovie_points,0:NPROCTOT_VAL-1) :: &
+ store_val_x_all,store_val_y_all,store_val_z_all, store_val_ux_all,store_val_uy_all,store_val_uz_all
+
+
+ ! read master receiver ID -- the ID in DATA/STATIONS
+ filename = 'NOISE_TOMOGRAPHY/'//'irec_master_noise'
+ open(unit=IIN_NOISE,file=trim(filename),status='old',action='read',iostat=ios)
+ if( ios /= 0) &
+ call exit_MPI(myrank, 'file '//trim(filename)//' does NOT exist! This file contains the ID of the master receiver')
+ read(IIN_NOISE,*,iostat=ios) irec_master_noise
+ close(IIN_NOISE)
+
+ if (myrank == 0) then
+ open(unit=IOUT_NOISE,file='OUTPUT_FILES/irec_master_noise',status='unknown',action='write')
+ WRITE(IOUT_NOISE,*) 'The master receiver is: (RECEIVER ID)', irec_master_noise
+ close(IOUT_NOISE)
+ endif
+
+ ! compute source arrays for "ensemble forward source", which is source of "ensemble forward wavefield"
+ if(myrank == islice_selected_rec(irec_master_noise) .OR. myrank == 0) then ! myrank == 0 is used for output only
+ call compute_arrays_source_noise(myrank, &
+ xi_receiver(irec_master_noise),eta_receiver(irec_master_noise),gamma_receiver(irec_master_noise), &
+ nu(:,:,irec_master_noise),noise_sourcearray, xigll,yigll,zigll,NSTEP)
+ endif
+
+ ! noise distribution and noise direction
+ ipoin = 0
+ do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ ispec = ibelm_top_crust_mantle(ispec2D)
+
+ k = NGLLZ
+
+ ! loop on all the points inside the element
+ do j = 1,NGLLY,NIT
+ do i = 1,NGLLX,NIT
+ ipoin = ipoin + 1
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+ ! this subroutine must be modified by USERS
+ call noise_distribution_direction(xstore_crust_mantle(iglob), &
+ ystore_crust_mantle(iglob),zstore_crust_mantle(iglob), &
+ normal_x_noise_out,normal_y_noise_out,normal_z_noise_out, &
+ mask_noise_out)
+ normal_x_noise(ipoin) = normal_x_noise_out
+ normal_y_noise(ipoin) = normal_y_noise_out
+ normal_z_noise(ipoin) = normal_z_noise_out
+ mask_noise(ipoin) = mask_noise_out
+ enddo
+ enddo
+
+ enddo
+
+ !!!BEGIN!!! save mask_noise for check, a file called "mask_noise" is saved in "./OUTPUT_FIELS/"
+ ipoin = 0
+ do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ ispec = ibelm_top_crust_mantle(ispec2D)
+ k = NGLLZ
+ ! loop on all the points inside the element
+ do j = 1,NGLLY,NIT
+ do i = 1,NGLLX,NIT
+ ipoin = ipoin + 1
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+ store_val_x(ipoin) = xstore_crust_mantle(iglob)
+ store_val_y(ipoin) = ystore_crust_mantle(iglob)
+ store_val_z(ipoin) = zstore_crust_mantle(iglob)
+ store_val_ux(ipoin) = mask_noise(ipoin)
+ store_val_uy(ipoin) = mask_noise(ipoin)
+ store_val_uz(ipoin) = mask_noise(ipoin)
+ enddo
+ enddo
+ enddo
+
+ ! gather info on master proc
+ ispec = nmovie_points
+ call MPI_GATHER(store_val_x,ispec,CUSTOM_MPI_TYPE,store_val_x_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(store_val_y,ispec,CUSTOM_MPI_TYPE,store_val_y_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(store_val_z,ispec,CUSTOM_MPI_TYPE,store_val_z_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(store_val_ux,ispec,CUSTOM_MPI_TYPE,store_val_ux_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(store_val_uy,ispec,CUSTOM_MPI_TYPE,store_val_uy_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(store_val_uz,ispec,CUSTOM_MPI_TYPE,store_val_uz_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+
+ ! save maks_noise data to disk in home directory
+ ! this file can be viewed the same way as surface movie data (xcreate_movie_AVS_DX)
+ ! create_movie_AVS_DX.f90 needs to be modified in order to do that,
+ ! i.e., instead of showing the normal component, change it to either x, y or z component, or the norm.
+ if(myrank == 0) then
+ open(unit=IOUT_NOISE,file='OUTPUT_FILES/mask_noise',status='unknown',form='unformatted',action='write')
+ write(IOUT_NOISE) store_val_x_all
+ write(IOUT_NOISE) store_val_y_all
+ write(IOUT_NOISE) store_val_z_all
+ write(IOUT_NOISE) store_val_ux_all
+ write(IOUT_NOISE) store_val_uy_all
+ write(IOUT_NOISE) store_val_uz_all
+ close(IOUT_NOISE)
+ endif
+ !!!END!!! save mask_noise for check, a file called "mask_noise" is saved in "./OUTPUT_FIELS/"
+
+ end subroutine read_parameters_noise
+
+! =============================================================================================================
+! =============================================================================================================
+! =============================================================================================================
+
+! subroutine for NOISE TOMOGRAPHY
+! check for consistency of the parameters
+ subroutine check_parameters_noise(myrank,NOISE_TOMOGRAPHY,SIMULATION_TYPE,SAVE_FORWARD, &
+ NUMBER_OF_RUNS, NUMBER_OF_THIS_RUN,ROTATE_SEISMOGRAMS_RT, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE, USE_BINARY_FOR_LARGE_FILE, &
+ MOVIE_COARSE)
+ implicit none
+ include 'mpif.h'
+ include "precision.h"
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+ ! input parameters
+ integer :: myrank,NOISE_TOMOGRAPHY,SIMULATION_TYPE,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN
+ logical :: SAVE_FORWARD,ROTATE_SEISMOGRAMS_RT,SAVE_ALL_SEISMOS_IN_ONE_FILE, USE_BINARY_FOR_LARGE_FILE,MOVIE_COARSE
+ ! output parameters
+ ! local parameters
+
+
+ if (myrank == 0) then
+ open(unit=IOUT_NOISE,file='OUTPUT_FILES/NOISE_SIMULATION',status='unknown',action='write')
+ WRITE(IOUT_NOISE,*) '*******************************************************************************'
+ WRITE(IOUT_NOISE,*) '*******************************************************************************'
+ WRITE(IOUT_NOISE,*) 'WARNING!!!!!!!!!!!!'
+ WRITE(IOUT_NOISE,*) 'You are running simulations using NOISE TOMOGRAPHY techniques.'
+ WRITE(IOUT_NOISE,*) 'Please make sure you understand the procedures before you have a try.'
+ WRITE(IOUT_NOISE,*) 'Displacements everywhere at the free surface are saved every timestep,'
+ WRITE(IOUT_NOISE,*) 'so make sure that LOCAL_PATH in DATA/Par_file is not global.'
+ WRITE(IOUT_NOISE,*) 'Otherwise the disk storage may be a serious issue, as is the speed of I/O.'
+ WRITE(IOUT_NOISE,*) 'Also make sure that NO earthquakes are included,'
+ WRITE(IOUT_NOISE,*) 'i.e., set moment tensor to be ZERO in CMTSOLUTION'
+ WRITE(IOUT_NOISE,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+ WRITE(IOUT_NOISE,*) 'If you just want a regular EARTHQUAKE simulation,'
+ WRITE(IOUT_NOISE,*) 'set NOISE_TOMOGRAPHY=0 in DATA/Par_file'
+ WRITE(IOUT_NOISE,*) '*******************************************************************************'
+ WRITE(IOUT_NOISE,*) '*******************************************************************************'
+ close(IOUT_NOISE)
+ endif
+
+ if (NUMBER_OF_RUNS/=1 .OR. NUMBER_OF_THIS_RUN/=1) &
+ call exit_mpi(myrank,'NUMBER_OF_RUNS and NUMBER_OF_THIS_RUN must be 1 for NOISE TOMOGRAPHY! check DATA/Par_file')
+ if (ROTATE_SEISMOGRAMS_RT) &
+ call exit_mpi(myrank,'Do NOT rotate seismograms in the code, change ROTATE_SEISMOGRAMS_RT in DATA/Par_file')
+ if (SAVE_ALL_SEISMOS_IN_ONE_FILE .OR. USE_BINARY_FOR_LARGE_FILE) &
+ call exit_mpi(myrank,'Please set SAVE_ALL_SEISMOS_IN_ONE_FILE and USE_BINARY_FOR_LARGE_FILE to be .false.')
+ if (MOVIE_COARSE) &
+ call exit_mpi(myrank,'Please set MOVIE_COARSE in DATA/Par_file to be .false.')
+
+
+ if (NOISE_TOMOGRAPHY==1) then
+ if (SIMULATION_TYPE/=1) &
+ call exit_mpi(myrank,'NOISE_TOMOGRAPHY=1 requires SIMULATION_TYPE=1! check DATA/Par_file')
+ else if (NOISE_TOMOGRAPHY==2) then
+ if (SIMULATION_TYPE/=1) &
+ call exit_mpi(myrank,'NOISE_TOMOGRAPHY=2 requires SIMULATION_TYPE=1! check DATA/Par_file')
+ if (.not. SAVE_FORWARD) &
+ call exit_mpi(myrank,'NOISE_TOMOGRAPHY=2 requires SAVE_FORWARD=.true.! check DATA/Par_file')
+ else if (NOISE_TOMOGRAPHY==3) then
+ if (SIMULATION_TYPE/=3) &
+ call exit_mpi(myrank,'NOISE_TOMOGRAPHY=3 requires SIMULATION_TYPE=3! check DATA/Par_file')
+ if (SAVE_FORWARD) &
+ call exit_mpi(myrank,'NOISE_TOMOGRAPHY=3 requires SAVE_FORWARD=.false.! check DATA/Par_file')
+ endif
+ end subroutine check_parameters_noise
+
+! =============================================================================================================
+! =============================================================================================================
+! =============================================================================================================
+
+! subroutine for NOISE TOMOGRAPHY
+! read and construct the "source" (source time function based upon noise spectrum) for "ensemble forward source"
+ subroutine compute_arrays_source_noise(myrank, &
+ xi_noise,eta_noise,gamma_noise,nu_single,noise_sourcearray, &
+ xigll,yigll,zigll,NSTEP)
+ implicit none
+ include 'constants.h'
+ include "OUTPUT_FILES/values_from_mesher.h"
+ ! input parameters
+ integer :: myrank, NSTEP
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+ double precision, dimension(NDIM,NDIM) :: nu_single ! rotation matrix at the master receiver
+ ! output parameters
+ real(kind=CUSTOM_REAL) :: noise_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NSTEP)
+ ! local parameters
+ integer itime, i, j, k, ios
+ real(kind=CUSTOM_REAL) :: junk
+ real(kind=CUSTOM_REAL) :: noise_src(NSTEP),noise_src_u(NDIM,NSTEP)
+ double precision, dimension(NDIM) :: nu_master ! component direction chosen at the master receiver
+ double precision :: xi_noise, eta_noise, gamma_noise ! master receiver location
+ double precision,parameter :: scale_displ_inv = 1.d0/R_EARTH ! non-dimesional scaling
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
+ hgammar(NGLLZ), hpgammar(NGLLZ)
+ character(len=150) :: filename
+
+
+ noise_src(:) = 0._CUSTOM_REAL
+ ! noise file (source time function)
+ filename = 'NOISE_TOMOGRAPHY/'//'S_squared'
+ open(unit=IIN_NOISE,file=trim(filename),status='old',action='read',iostat=ios)
+ if( ios /= 0) &
+ call exit_MPI(myrank, 'file '//trim(filename)//' does NOT exist! This file is generated by Matlab scripts')
+
+ do itime =1,NSTEP
+ read(IIN_NOISE,*,iostat=ios) junk, noise_src(itime)
+ if( ios /= 0) call exit_MPI(myrank,&
+ 'file '//trim(filename)//' has wrong length, please check your simulation duration')
+ enddo
+ close(IIN_NOISE)
+
+ ! master receiver component direction, \nu_master
+ filename = 'NOISE_TOMOGRAPHY/'//'nu_master'
+ open(unit=IIN_NOISE,file=trim(filename),status='old',action='read',iostat=ios)
+ if( ios /= 0) call exit_MPI(myrank,&
+ 'file '//trim(filename)//' does NOT exist! nu_master is the component direction (NEZ) for master receiver')
+
+ do itime =1,3
+ read(IIN_NOISE,*,iostat=ios) nu_master(itime)
+ if( ios /= 0) call exit_MPI(myrank,&
+ 'file '//trim(filename)//' has wrong length, the vector should have three components (NEZ)')
+ enddo
+ close(IIN_NOISE)
+
+ if (myrank == 0) then
+ open(unit=IOUT_NOISE,file='OUTPUT_FILES/nu_master',status='unknown',action='write')
+ WRITE(IOUT_NOISE,*) 'The direction (NEZ) of selected component of master receiver is', nu_master
+ close(IOUT_NOISE)
+ endif
+
+ ! rotates to cartesian
+ do itime = 1, NSTEP
+ noise_src_u(:,itime) = nu_single(1,:) * noise_src(itime) * nu_master(1) &
+ + nu_single(2,:) * noise_src(itime) * nu_master(2) &
+ + nu_single(3,:) * noise_src(itime) * nu_master(3)
+ enddo
+
+ ! receiver interpolators
+ call lagrange_any(xi_noise,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_noise,NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_noise,NGLLZ,zigll,hgammar,hpgammar)
+
+ ! adds interpolated source contribution to all GLL points within this element
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ do itime = 1, NSTEP
+ noise_sourcearray(:,i,j,k,itime) = hxir(i) * hetar(j) * hgammar(k) * noise_src_u(:,itime)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_arrays_source_noise
+
+! =============================================================================================================
+! =============================================================================================================
+! =============================================================================================================
+
+! subroutine for NOISE TOMOGRAPHY
+! step 1: calculate the "ensemble forward source"
+! add noise spectrum to the location of master receiver
+ subroutine add_source_master_rec_noise(myrank,nrec, &
+ NSTEP,accel_crust_mantle,noise_sourcearray, &
+ ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
+ it,irec_master_noise)
+ implicit none
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+ ! input parameters
+ integer :: myrank,nrec,NSTEP, irec_master_noise
+ integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSTEP) :: noise_sourcearray
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle ! both input and output
+ ! output parameters
+ ! local parameters
+ integer :: i,j,k,iglob,it
+
+
+ ! adds noise source (only if this proc carries the noise)
+ if(myrank == islice_selected_rec(irec_master_noise)) then
+ ! adds nosie source contributions
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec_master_noise))
+ accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
+ + noise_sourcearray(:,i,j,k,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ end subroutine add_source_master_rec_noise
+
+! =============================================================================================================
+! =============================================================================================================
+! =============================================================================================================
+
+! subroutine for NOISE TOMOGRAPHY
+! step 1: calculate the "ensemble forward source"
+! save surface movie (displacement) at every time steps, for step 2 & 3.
+ subroutine noise_save_surface_movie(myrank,nmovie_points,displ_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ ibelm_top_crust_mantle,ibool_crust_mantle,nspec_top, &
+ NIT,it,LOCAL_PATH)
+ implicit none
+ include 'mpif.h'
+ include "precision.h"
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+ ! input parameters
+ integer :: myrank,nmovie_points,nspec_top,NIT,it
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+ character(len=150) :: LOCAL_PATH
+ ! output parameters
+ ! local parameters
+ integer :: ipoin,ispec2D,ispec,i,j,k,iglob
+ real(kind=CUSTOM_REAL), dimension(nmovie_points) :: &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_ux,store_val_uy,store_val_uz
+ character(len=150) :: outputname
+
+
+ ! get coordinates of surface mesh and surface displacement
+ ipoin = 0
+ do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ ispec = ibelm_top_crust_mantle(ispec2D)
+
+ k = NGLLZ
+
+ ! loop on all the points inside the element
+ do j = 1,NGLLY,NIT
+ do i = 1,NGLLX,NIT
+ ipoin = ipoin + 1
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+ store_val_x(ipoin) = xstore_crust_mantle(iglob)
+ store_val_y(ipoin) = ystore_crust_mantle(iglob)
+ store_val_z(ipoin) = zstore_crust_mantle(iglob)
+ store_val_ux(ipoin) = displ_crust_mantle(1,iglob)
+ store_val_uy(ipoin) = displ_crust_mantle(2,iglob)
+ store_val_uz(ipoin) = displ_crust_mantle(3,iglob)
+ enddo
+ enddo
+
+ enddo
+
+ ! save surface motion to disk
+ ! LOCAL storage is better than GLOBAL, because we have to save the 'movie' at every time step
+ ! also note that the surface movie does NOT have to be shared with other nodes/CPUs
+ ! change LOCAL_PATH specified in "DATA/Par_file"
+ write(outputname,"('/proc',i6.6,'_surface_movie',i6.6)") myrank, it
+ open(unit=IOUT_NOISE,file=trim(LOCAL_PATH)//outputname,status='unknown',form='unformatted',action='write')
+ write(IOUT_NOISE) store_val_ux
+ write(IOUT_NOISE) store_val_uy
+ write(IOUT_NOISE) store_val_uz
+ close(IOUT_NOISE)
+
+ end subroutine noise_save_surface_movie
+
+! =============================================================================================================
+! =============================================================================================================
+! =============================================================================================================
+
+! subroutine for NOISE TOMOGRAPHY
+! step 2/3: calculate/reconstructe the "ensemble forward wavefield"
+! read surface movie (displacement) at every time steps, injected as the source of "ensemble forward wavefield"
+! in step 2, call noise_read_add_surface_movie(..., NSTEP-it+1 ,...)
+! in step 3, call noise_read_add_surface_movie(..., it ,...)
+ subroutine noise_read_add_surface_movie(myrank,nmovie_points,accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ ibelm_top_crust_mantle,ibool_crust_mantle,nspec_top, &
+ NIT,it,LOCAL_PATH,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ implicit none
+ include 'mpif.h'
+ include "precision.h"
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+ ! input parameters
+ integer :: myrank,nmovie_points,nspec_top,NIT,it
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: jacobian2D_top_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle ! both input and output
+ real(kind=CUSTOM_REAL), dimension(nmovie_points) :: normal_x_noise,normal_y_noise,normal_z_noise, mask_noise
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ character(len=150) :: LOCAL_PATH
+ ! output parameters
+ ! local parameters
+ integer :: ipoin,ispec2D,ispec,i,j,k,iglob,ios
+ real(kind=CUSTOM_REAL), dimension(nmovie_points) :: store_val_ux,store_val_uy,store_val_uz
+ real(kind=CUSTOM_REAL) :: eta
+ character(len=150) :: outputname
+
+
+ ! read surface movie
+ write(outputname,"('/proc',i6.6,'_surface_movie',i6.6)") myrank, it
+ open(unit=IIN_NOISE,file=trim(LOCAL_PATH)//outputname,status='old',form='unformatted',action='read',iostat=ios)
+ if( ios /= 0) call exit_MPI(myrank,'file '//trim(outputname)//' does NOT exist!')
+ read(IIN_NOISE) store_val_ux
+ read(IIN_NOISE) store_val_uy
+ read(IIN_NOISE) store_val_uz
+ close(IIN_NOISE)
+
+ ! get coordinates of surface mesh and surface displacement
+ ipoin = 0
+ do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ ispec = ibelm_top_crust_mantle(ispec2D)
+
+ k = NGLLZ
+
+ ! loop on all the points inside the element
+ do j = 1,NGLLY,NIT
+ do i = 1,NGLLX,NIT
+ ipoin = ipoin + 1
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+
+ eta = store_val_ux(ipoin) * normal_x_noise(ipoin) + &
+ store_val_uy(ipoin) * normal_y_noise(ipoin) + &
+ store_val_uz(ipoin) * normal_z_noise(ipoin)
+
+ accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + eta * mask_noise(ipoin) * normal_x_noise(ipoin) &
+ * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
+ accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + eta * mask_noise(ipoin) * normal_y_noise(ipoin) &
+ * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
+ accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + eta * mask_noise(ipoin) * normal_z_noise(ipoin) &
+ * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine noise_read_add_surface_movie
+
+! =============================================================================================================
+! =============================================================================================================
+! =============================================================================================================
+
+! subroutine for NOISE TOMOGRAPHY
+! step 3: constructing noise source strength kernel
+ subroutine compute_kernels_strength_noise(myrank,ibool_crust_mantle, &
+ Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
+ nmovie_points,normal_x_noise,normal_y_noise,normal_z_noise, &
+ nspec_top,ibelm_top_crust_mantle,LOCAL_PATH)
+ implicit none
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+ ! input parameters
+ integer :: myrank,nmovie_points,it,nspec_top
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ real(kind=CUSTOM_REAL) :: deltat
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: displ_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(nmovie_points) :: normal_x_noise,normal_y_noise,normal_z_noise
+ character(len=150) :: LOCAL_PATH
+ ! output parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ Sigma_kl_crust_mantle
+ ! local parameters
+ integer :: i,j,k,ispec,iglob,ipoin,ispec2D,ios
+ real(kind=CUSTOM_REAL) :: eta
+ real(kind=CUSTOM_REAL), dimension(nmovie_points) :: store_val_ux,store_val_uy,store_val_uz
+ character(len=150) :: outputname
+
+
+ ! read surface movie, needed for Sigma_kl_crust_mantle
+ write(outputname,"('/proc',i6.6,'_surface_movie',i6.6)") myrank, it
+ open(unit=IIN_NOISE,file=trim(LOCAL_PATH)//outputname,status='old',form='unformatted',action='read',iostat=ios)
+ if( ios /= 0) call exit_MPI(myrank,'file '//trim(outputname)//' does NOT exist!')
+
+ read(IIN_NOISE) store_val_ux
+ read(IIN_NOISE) store_val_uy
+ read(IIN_NOISE) store_val_uz
+ close(IIN_NOISE)
+
+ ! noise source strength kernel
+ ! to keep similar structure to other kernels, the source strength kernel is saved as a volumetric kernel
+ ! but only updated at the surface, because the noise is generated there
+ ipoin = 0
+ do ispec2D = 1, nspec_top
+ ispec = ibelm_top_crust_mantle(ispec2D)
+
+ k = NGLLZ
+
+ ! loop on all the points inside the element
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+
+ eta = store_val_ux(ipoin) * normal_x_noise(ipoin) + &
+ store_val_uy(ipoin) * normal_y_noise(ipoin) + &
+ store_val_uz(ipoin) * normal_z_noise(ipoin)
+
+ Sigma_kl_crust_mantle(i,j,k,ispec) = Sigma_kl_crust_mantle(i,j,k,ispec) &
+ + deltat * eta * ( normal_x_noise(ipoin) * displ_crust_mantle(1,iglob) &
+ + normal_y_noise(ipoin) * displ_crust_mantle(2,iglob) &
+ + normal_z_noise(ipoin) * displ_crust_mantle(3,iglob) )
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine compute_kernels_strength_noise
+
+! =============================================================================================================
+! =============================================================================================================
+! =============================================================================================================
+
+! subroutine for NOISE TOMOGRAPHY
+! step 3: save noise source strength kernel
+ subroutine save_kernels_strength_noise(myrank,LOCAL_PATH,Sigma_kl_crust_mantle)
+ implicit none
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+ ! input parameters
+ integer myrank
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: Sigma_kl_crust_mantle
+ character(len=150) :: LOCAL_PATH
+ ! output parameters
+ ! local parameters
+ character(len=150) :: prname
+
+
+ call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
+
+ open(unit=IOUT_NOISE,file=trim(prname)//'Sigma_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(IOUT_NOISE) Sigma_kl_crust_mantle ! need to put dimensions back (not done yet)
+ close(IOUT_NOISE)
+ end subroutine save_kernels_strength_noise
+
+! =============================================================================================================
+! =============================================================================================================
+! =============================================================================================================
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/param_reader.c (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/param_reader.c)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/param_reader.c (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/param_reader.c 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,211 @@
+/*
+ !=====================================================================
+ !
+ ! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+ ! --------------------------------------------------
+ !
+ ! Main authors: Dimitri Komatitsch and Jeroen Tromp
+ ! Princeton University, USA
+ ! and University of Pau / CNRS / INRIA, France
+ ! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+ ! December 2010
+ !
+ ! 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.
+ !
+ !=====================================================================
+ */
+
+/*
+
+by Dennis McRitchie (Princeton University, USA)
+
+ January 7, 2010 - par_file parsing
+ ..
+ You'll notice that the heart of the parser is a complex regular
+ expression that is compiled within the C code, and then used to split
+ the lines appropriately. It does all the heavy lifting. I don't know of
+ any way to do this in Fortran. I believe that to accomplish this in
+ Fortran, you'd have to write a lot of procedural string manipulation
+ code, for which Fortran is not very well suited.
+
+ But Fortran-C mixes are pretty common these days, so I would not expect
+ any problems on that account. There are no wrapper functions used: just
+ the C routine called directly from a Fortran routine. Also, regarding
+ the use of C, I assumed this would not be a problem since there are
+ already six C files that make up part of the build (though they all are
+ related to the pyre-framework).
+ ..
+*/
+
+#define _GNU_SOURCE
+#include "config.h"
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <regex.h>
+
+#define LINE_MAX 255
+
+/*
+ * Mac OS X's gcc does not support strnlen and strndup.
+ * So we define them here conditionally, to avoid duplicate definitions
+ * on other systems.
+ */
+#ifdef __APPLE__
+size_t strnlen (const char *string, size_t maxlen)
+{
+ const char *end = memchr (string, '\0', maxlen);
+ return end ? (size_t) (end - string) : maxlen;
+}
+
+char *strndup (char const *s, size_t n)
+{
+ size_t len = strnlen (s, n);
+ char *new = malloc (len + 1);
+
+ if (new == NULL)
+ return NULL;
+
+ new[len] = '\0';
+ return memcpy (new, s, len);
+}
+#endif
+/*===============================================================*/
+
+FILE * fid;
+
+void
+FC_FUNC_(param_open,PARAM_OPEN)(char * filename, int * length, int * ierr)
+{
+ char * fncopy;
+ char * blank;
+
+ // Trim the file name.
+ fncopy = strndup(filename, *length);
+ blank = strchr(fncopy, ' ');
+ if (blank != NULL) {
+ fncopy[blank - fncopy] = '\0';
+ }
+ if ((fid = fopen(fncopy, "r")) == NULL) {
+ printf("Can't open '%s'\n", fncopy);
+ *ierr = 1;
+ return;
+ }
+ free(fncopy);
+}
+
+void
+FC_FUNC_(param_close,PARAM_CLOSE)()
+{
+ fclose(fid);
+}
+
+void
+FC_FUNC_(param_read,PARAM_READ)(char * string_read, int * string_read_len, char * name, int * name_len, int * ierr)
+{
+ char * namecopy;
+ char * blank;
+ char * namecopy2;
+ int status;
+ regex_t compiled_pattern;
+ char line[LINE_MAX];
+ int regret;
+ regmatch_t parameter[3];
+ char * keyword;
+ char * value;
+
+ // Trim the keyword name we're looking for.
+ namecopy = strndup(name, *name_len);
+ blank = strchr(namecopy, ' ');
+ if (blank != NULL) {
+ namecopy[blank - namecopy] = '\0';
+ }
+ // Then get rid of any dot-terminated prefix.
+ namecopy2 = strchr(namecopy, '.');
+ if (namecopy2 != NULL) {
+ namecopy2 += 1;
+ } else {
+ namecopy2 = namecopy;
+ }
+ /* Regular expression for parsing lines from param file.
+ ** Good luck reading this regular expression. Basically, the lines of
+ ** the parameter file should be of the form 'parameter = value'. Blank
+ ** lines, lines containing only white space and lines whose first non-
+ ** whitespace character is '#' are ignored. White space is generally
+ ** ignored. As you will see later in the code, if both parameter and
+ ** value are not specified the line is ignored.
+ */
+ char pattern[] = "^[ \t]*([^# \t]*)[ \t]*=[ \t]*([^# \t]*)[ \t]*(#.*){0,1}$";
+
+ // Compile the regular expression.
+ status = regcomp(&compiled_pattern, pattern, REG_EXTENDED);
+ if (status != 0) {
+ printf("regcomp returned error %d\n", status);
+ }
+ // Position the open file to the beginning.
+ if (fseek(fid, 0, SEEK_SET) != 0) {
+ printf("Can't seek to begining of parameter file\n");
+ *ierr = 1;
+ regfree(&compiled_pattern);
+ return;
+ }
+ // Read every line in the file.
+ while (fgets(line, LINE_MAX, fid) != NULL) {
+ // Get rid of the ending newline.
+ int linelen = strlen(line);
+ if (line[linelen-1] == '\n') {
+ line[linelen-1] = '\0';
+ }
+ /* Test if line matches the regular expression pattern, if so
+ ** return position of keyword and value */
+ regret = regexec(&compiled_pattern, line, 3, parameter, 0);
+ // If no match, check the next line.
+ if (regret == REG_NOMATCH) {
+ continue;
+ }
+ // If any error, bail out with an error message.
+ if(regret != 0) {
+ printf("regexec returned error %d\n", regret);
+ *ierr = 1;
+ regfree(&compiled_pattern);
+ return;
+ }
+ // printf("Line read = %s\n", line);
+ // If we have a match, extract the keyword from the line.
+ keyword = strndup(line+parameter[1].rm_so, parameter[1].rm_eo-parameter[1].rm_so);
+ // If the keyword is not the one we're looking for, check the next line.
+ if (strcmp(keyword, namecopy2) != 0) {
+ free(keyword);
+ continue;
+ }
+ free(keyword);
+ regfree(&compiled_pattern);
+ // If it matches, extract the value from the line.
+ value = strndup(line+parameter[2].rm_so, parameter[2].rm_eo-parameter[2].rm_so);
+ // Clear out the return string with blanks, copy the value into it, and return.
+ memset(string_read, ' ', *string_read_len);
+ strncpy(string_read, value, strlen(value));
+ free(value);
+ free(namecopy);
+ *ierr = 0;
+ return;
+ }
+ // If no keyword matches, print out error and die.
+ printf("No match in parameter file for keyword %s\n", namecopy);
+ free(namecopy);
+ regfree(&compiled_pattern);
+ *ierr = 1;
+ return;
+}
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/prepare_timerun.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/prepare_timerun.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/prepare_timerun.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/prepare_timerun.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,711 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine prepare_timerun_rmass(myrank,rmass_ocean_load,rmass_crust_mantle, &
+ rmass_outer_core,rmass_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_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, &
+ 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_scalar,buffer_received_faces_scalar, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,npoin2D_max_all_CM_IC)
+
+ implicit none
+
+ include 'mpif.h'
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank,npoin2D_max_all_CM_IC
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
+ 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
+
+ integer ichunk,iproc_xi,iproc_eta
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-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_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
+
+ integer, 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
+
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle, &
+ iboolfaces_outer_core,iboolfaces_inner_core
+
+ integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer npoin2D_faces_outer_core(NUMFACES_SHARED)
+ integer npoin2D_faces_inner_core(NUMFACES_SHARED)
+
+ ! 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
+
+ ! 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
+
+ ! buffers for send and receive between faces of the slices and the chunks
+ real(kind=CUSTOM_REAL), dimension(NGLOB2DMAX_XY_VAL) :: &
+ 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_CM) :: &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar
+
+ integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS
+
+ integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+ integer NGLOB2DMAX_XY
+
+ ! local parameters
+ integer :: ier
+
+ ! 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_VAL) then
+ call assemble_MPI_scalar_block(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_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY,NCHUNKS_VAL)
+ endif
+
+ ! crust and mantle
+ call assemble_MPI_scalar_block(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_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY,NCHUNKS_VAL)
+
+ ! outer core
+ call assemble_MPI_scalar_block(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_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY,NCHUNKS_VAL)
+
+ ! inner core
+ call assemble_MPI_scalar_block(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_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE),NGLOB2DMAX_XY,NCHUNKS_VAL)
+
+ if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix'
+
+ end subroutine prepare_timerun_rmass
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_timerun_centralcube(myrank,rmass_inner_core, &
+ iproc_xi,iproc_eta,ichunk, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM, &
+ 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
+
+ include 'mpif.h'
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
+
+ integer ichunk,iproc_xi,iproc_eta
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core
+
+ integer nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
+ nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
+
+ integer nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube, &
+ npoin2D_cube_from_slices,receiver_cube_from_slices
+
+ integer, dimension(non_zero_nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
+ integer, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices) :: ibool_central_cube
+ double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices,buffer_slices2
+ double precision, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM) :: &
+ buffer_all_cube_from_slices
+
+ ! local parameters
+ integer :: ndim_assemble
+
+ ! create buffers to assemble with the central cube
+ call create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NCHUNKS_VAL,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_block(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.
+
+ end subroutine prepare_timerun_centralcube
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_timerun_constants(myrank,NSTEP, &
+ DT,t0,scale_t,scale_t_inv,scale_displ,scale_veloc, &
+ deltat,deltatover2,deltatsqover2, &
+ b_deltat,b_deltatover2,b_deltatsqover2, &
+ two_omega_earth,A_array_rotation,B_array_rotation, &
+ b_two_omega_earth, SIMULATION_TYPE)
+
+! precomputes constants for time integration
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank,NSTEP
+
+ double precision DT
+ double precision t0
+
+
+ double precision scale_t,scale_t_inv,scale_displ,scale_veloc
+
+ real(kind=CUSTOM_REAL) deltat,deltatover2,deltatsqover2
+ real(kind=CUSTOM_REAL) b_deltat,b_deltatover2,b_deltatsqover2
+
+ real(kind=CUSTOM_REAL) two_omega_earth
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
+ A_array_rotation,B_array_rotation
+
+ real(kind=CUSTOM_REAL) b_two_omega_earth
+
+ integer SIMULATION_TYPE
+
+ ! local parameters
+
+
+ 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_t_inv = dsqrt(PI*GRAV*RHOAV)
+
+ scale_displ = R_EARTH
+
+ scale_veloc = scale_displ * scale_t_inv
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ deltat = sngl(DT*scale_t_inv)
+ else
+ deltat = DT*scale_t_inv
+ endif
+ deltatover2 = 0.5d0*deltat
+ deltatsqover2 = 0.5d0*deltat*deltat
+
+ if (SIMULATION_TYPE == 3) then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ b_deltat = - sngl(DT*scale_t_inv)
+ else
+ b_deltat = - DT*scale_t_inv
+ endif
+ b_deltatover2 = 0.5d0*b_deltat
+ b_deltatsqover2 = 0.5d0*b_deltat*b_deltat
+ endif
+
+ ! non-dimensionalized rotation rate of the Earth times two
+ if(ROTATION_VAL) then
+ ! distinguish between single and double precision for reals
+ if (SIMULATION_TYPE == 1) then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ two_omega_earth = sngl(2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv))
+ else
+ two_omega_earth = 2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv)
+ endif
+ else
+ if(CUSTOM_REAL == SIZE_REAL) then
+ two_omega_earth = - sngl(2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv))
+ else
+ two_omega_earth = - 2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv)
+ endif
+ endif
+
+ A_array_rotation = 0._CUSTOM_REAL
+ B_array_rotation = 0._CUSTOM_REAL
+
+ if (SIMULATION_TYPE == 3) then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ b_two_omega_earth = sngl(2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv))
+ else
+ b_two_omega_earth = 2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv)
+ endif
+ endif
+ else
+ two_omega_earth = 0._CUSTOM_REAL
+ if (SIMULATION_TYPE == 3) b_two_omega_earth = 0._CUSTOM_REAL
+ endif
+
+
+ end subroutine prepare_timerun_constants
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_timerun_gravity(myrank, &
+ minus_g_cmb,minus_g_icb, &
+ minus_gravity_table,minus_deriv_gravity_table, &
+ density_table,d_ln_density_dr_table,minus_rho_g_over_kappa_fluid, &
+ ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+! precomputes gravity factors
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ real(kind=CUSTOM_REAL) minus_g_cmb,minus_g_icb
+
+ ! lookup table every km for gravity
+ double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table, &
+ minus_deriv_gravity_table,density_table, &
+ d_ln_density_dr_table,minus_rho_g_over_kappa_fluid
+
+ logical ONE_CRUST
+
+ double precision RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R80,R220,R400,R600,R670,R771,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ ! local parameters
+ double precision :: rspl_gravity(NR),gspl(NR),gspl2(NR)
+ double precision :: radius,radius_km,g,dg
+ double precision :: g_cmb_dble,g_icb_dble
+ double precision :: rho,drhodr,vp,vs,Qkappa,Qmu
+ integer :: int_radius,idoubling,nspl_gravity
+
+ ! 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
+ if(GRAVITY_VAL) then
+ call make_gravity(nspl_gravity,rspl_gravity,gspl,gspl2,ONE_CRUST)
+ do int_radius = 1,NRAD_GRAVITY
+ radius = dble(int_radius) / (R_EARTH_KM * 10.d0)
+ call spline_evaluation(rspl_gravity,gspl,gspl2,nspl_gravity,radius,g)
+
+ ! use PREM density profile to calculate gravity (fine for other 1D models)
+ idoubling = 0
+ call model_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)
+
+ dg = 4.0d0*rho - 2.0d0*g/radius
+
+ minus_gravity_table(int_radius) = - g
+ minus_deriv_gravity_table(int_radius) = - dg
+ density_table(int_radius) = rho
+ minus_rho_g_over_kappa_fluid(int_radius) = - g / vp**2
+ enddo
+
+ ! make sure fluid array is only assigned in outer core between 1222 and 3478 km
+ ! lookup table is defined every 100 m
+ do int_radius = 1,NRAD_GRAVITY
+ radius_km = dble(int_radius) / 10.d0
+ if(radius_km > RCMB/1000.d0 - 3.d0) &
+ minus_rho_g_over_kappa_fluid(int_radius) = minus_rho_g_over_kappa_fluid(nint((RCMB/1000.d0 - 3.d0)*10.d0))
+ if(radius_km < RICB/1000.d0 + 3.d0) &
+ minus_rho_g_over_kappa_fluid(int_radius) = minus_rho_g_over_kappa_fluid(nint((RICB/1000.d0 + 3.d0)*10.d0))
+ enddo
+
+ ! compute gravity value at CMB and ICB once and for all
+ radius = RCMB / R_EARTH
+ call spline_evaluation(rspl_gravity,gspl,gspl2,nspl_gravity,radius,g_cmb_dble)
+
+ radius = RICB / R_EARTH
+ call spline_evaluation(rspl_gravity,gspl,gspl2,nspl_gravity,radius,g_icb_dble)
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ minus_g_cmb = sngl(- g_cmb_dble)
+ minus_g_icb = sngl(- g_icb_dble)
+ else
+ minus_g_cmb = - g_cmb_dble
+ minus_g_icb = - g_icb_dble
+ endif
+
+ else
+
+ ! 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 model_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
+
+ endif
+
+ end subroutine prepare_timerun_gravity
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_timerun_attenuation(myrank, &
+ factor_scale_crust_mantle,one_minus_sum_beta_crust_mantle,factor_common_crust_mantle, &
+ factor_scale_inner_core,one_minus_sum_beta_inner_core,factor_common_inner_core, &
+ 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, &
+ muvstore_crust_mantle,muhstore_crust_mantle,idoubling_crust_mantle, &
+ muvstore_inner_core, &
+ SIMULATION_TYPE,MOVIE_VOLUME,muvstore_crust_mantle_3dmovie, &
+ c11store_inner_core,c12store_inner_core,c13store_inner_core, &
+ c33store_inner_core,c44store_inner_core, &
+ alphaval,betaval,gammaval,b_alphaval,b_betaval,b_gammaval, &
+ deltat,b_deltat,LOCAL_PATH)
+
+ ! precomputes attenuation factors
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ ! memory variables and standard linear solids for attenuation
+ real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT4) :: one_minus_sum_beta_crust_mantle, factor_scale_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(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
+
+ 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
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
+ muvstore_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ muhstore_crust_mantle
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
+ muvstore_inner_core
+
+
+ integer SIMULATION_TYPE
+ logical MOVIE_VOLUME
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: muvstore_crust_mantle_3dmovie
+
+ 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
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval, betaval, gammaval
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: b_alphaval, b_betaval, b_gammaval
+
+ real(kind=CUSTOM_REAL) deltat,b_deltat
+
+ character(len=150) LOCAL_PATH
+
+ ! local parameters
+ 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
+ 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, dimension(N_SLS) :: alphaval_dble, betaval_dble, gammaval_dble
+ double precision, dimension(N_SLS) :: tau_sigma_dble
+
+ double precision :: scale_factor,scale_factor_minus_one
+ real(kind=CUSTOM_REAL) :: mul
+ integer :: ispec,i,j,k
+ character(len=150) :: prname
+
+ ! get and store PREM attenuation model
+
+ ! CRUST_MANTLE ATTENUATION
+ call create_name_database(prname, myrank, IREGION_CRUST_MANTLE, LOCAL_PATH)
+ call get_attenuation_model_3D(myrank, prname, omsb_crust_mantle_dble, &
+ factor_common_crust_mantle_dble,factor_scale_crust_mantle_dble,tau_sigma_dble,NSPEC_CRUST_MANTLE)
+
+ ! INNER_CORE ATTENUATION
+ call create_name_database(prname, myrank, IREGION_INNER_CORE, LOCAL_PATH)
+ call get_attenuation_model_3D(myrank, prname, omsb_inner_core_dble, &
+ factor_common_inner_core_dble,factor_scale_inner_core_dble,tau_sigma_dble,NSPEC_INNER_CORE)
+
+ 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
+ scale_factor = factor_scale_crust_mantle(i,j,k,ispec)
+
+ 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
+ if(MOVIE_VOLUME .and. SIMULATION_TYPE==3) then
+ ! store the original value of \mu to comput \mu*\eps
+ muvstore_crust_mantle_3dmovie(i,j,k,ispec)=muvstore_crust_mantle(i,j,k,ispec)
+ endif
+ muvstore_crust_mantle(i,j,k,ispec) = muvstore_crust_mantle(i,j,k,ispec) * scale_factor
+ 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
+ scale_factor_minus_one = factor_scale_inner_core(i,j,k,ispec) - 1.0
+
+ 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
+
+ muvstore_inner_core(i,j,k,ispec) = muvstore_inner_core(i,j,k,ispec) * factor_scale_inner_core(i,j,k,ispec)
+
+ enddo
+ enddo
+ enddo
+ enddo ! END DO INNER CORE
+
+ ! precompute Runge-Kutta coefficients
+ call get_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
+
+ if (SIMULATION_TYPE == 3) then
+ call get_attenuation_memory_values(tau_sigma_dble, b_deltat, alphaval_dble, betaval_dble, gammaval_dble)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ b_alphaval = sngl(alphaval_dble)
+ b_betaval = sngl(betaval_dble)
+ b_gammaval = sngl(gammaval_dble)
+ else
+ b_alphaval = alphaval_dble
+ b_betaval = betaval_dble
+ b_gammaval = gammaval_dble
+ endif
+ endif
+
+ end subroutine prepare_timerun_attenuation
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_arrays_buffers_solver.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/read_arrays_buffers_solver.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_arrays_buffers_solver.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_arrays_buffers_solver.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,289 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine read_arrays_buffers_solver(iregion_code,myrank, &
+ iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
+ npoin2D_xi,npoin2D_eta, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces,npoin2D_faces,iboolcorner, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL, &
+ NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA,LOCAL_PATH,NCHUNKS)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+
+ integer iregion_code,myrank,NCHUNKS,ier
+
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
+ integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL
+ integer NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA
+
+ integer npoin2D_faces(NUMFACES_SHARED)
+
+ character(len=150) LOCAL_PATH
+
+ integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
+ integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+
+ integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
+
+! allocate array for messages for corners
+ integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+ integer npoin2D_xi_mesher,npoin2D_eta_mesher
+ integer npoin1D_corner
+
+ integer imsg,icount_faces,icount_corners
+ integer ipoin1D,ipoin2D
+
+ double precision xdummy,ydummy,zdummy
+
+! processor identification
+ character(len=150) OUTPUT_FILES,prname,filename
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+
+! read 2-D addressing for summation between slices along xi with MPI
+
+! read iboolleft_xi of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_xi.txt',status='old',action='read')
+ npoin2D_xi(1) = 1
+ 350 continue
+ read(IIN,*) iboolleft_xi(npoin2D_xi(1)),xdummy,ydummy,zdummy
+ if(iboolleft_xi(npoin2D_xi(1)) > 0) then
+ npoin2D_xi(1) = npoin2D_xi(1) + 1
+ goto 350
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_xi(1) = npoin2D_xi(1) - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_xi_mesher
+ if(npoin2D_xi(1) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(1) /= npoin2D_xi_mesher) &
+ call exit_MPI(myrank,'incorrect iboolleft_xi read')
+ close(IIN)
+
+! read iboolright_xi of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_xi.txt',status='old',action='read')
+ npoin2D_xi(2) = 1
+ 360 continue
+ read(IIN,*) iboolright_xi(npoin2D_xi(2)),xdummy,ydummy,zdummy
+ if(iboolright_xi(npoin2D_xi(2)) > 0) then
+ npoin2D_xi(2) = npoin2D_xi(2) + 1
+ goto 360
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_xi(2) = npoin2D_xi(2) - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_xi_mesher
+ if(npoin2D_xi(2) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(2) /= npoin2D_xi_mesher) &
+ call exit_MPI(myrank,'incorrect iboolright_xi read')
+ close(IIN)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '# max of points in MPI buffers along xi npoin2D_xi = ', &
+ maxval(npoin2D_xi(:))
+ write(IMAIN,*) '# max of array elements transferred npoin2D_xi*NDIM = ', &
+ maxval(npoin2D_xi(:))*NDIM
+ write(IMAIN,*)
+ endif
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! read 2-D addressing for summation between slices along eta with MPI
+
+! read iboolleft_eta of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_eta.txt',status='old',action='read')
+ npoin2D_eta(1) = 1
+ 370 continue
+ read(IIN,*) iboolleft_eta(npoin2D_eta(1)),xdummy,ydummy,zdummy
+ if(iboolleft_eta(npoin2D_eta(1)) > 0) then
+ npoin2D_eta(1) = npoin2D_eta(1) + 1
+ goto 370
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_eta(1) = npoin2D_eta(1) - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_eta_mesher
+ if(npoin2D_eta(1) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(1) /= npoin2D_eta_mesher) &
+ call exit_MPI(myrank,'incorrect iboolleft_eta read')
+ close(IIN)
+
+! read iboolright_eta of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='old',action='read')
+ npoin2D_eta(2) = 1
+ 380 continue
+ read(IIN,*) iboolright_eta(npoin2D_eta(2)),xdummy,ydummy,zdummy
+ if(iboolright_eta(npoin2D_eta(2)) > 0) then
+ npoin2D_eta(2) = npoin2D_eta(2) + 1
+ goto 380
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_eta(2) = npoin2D_eta(2) - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_eta_mesher
+ if(npoin2D_eta(2) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(2) /= npoin2D_eta_mesher) &
+ call exit_MPI(myrank,'incorrect iboolright_eta read')
+ close(IIN)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '#max of points in MPI buffers along eta npoin2D_eta = ', &
+ maxval(npoin2D_eta(:))
+ write(IMAIN,*) '#max of array elements transferred npoin2D_eta*NDIM = ', &
+ maxval(npoin2D_eta(:))*NDIM
+ write(IMAIN,*)
+ endif
+
+
+!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! read chunk messages only if more than one chunk
+ if(NCHUNKS /= 1) then
+
+! read messages to assemble between chunks with MPI
+
+ if(myrank == 0) then
+
+! 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
+ 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
+ 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
+ call MPI_BCAST(imsg_type,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iprocfrom_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iprocto_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(iproc_master_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iproc_worker1_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iproc_worker2_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+!---- read indirect addressing for each message for faces of the chunks
+!---- 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)) 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')
+
+! read file with 2D buffer for faces
+ if(myrank == iprocfrom_faces(imsg)) then
+ write(filename,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
+ else if(myrank == iprocto_faces(imsg)) then
+ write(filename,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
+ endif
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//filename,status='old',action='read')
+ read(IIN,*) npoin2D_faces(icount_faces)
+ if(npoin2D_faces(icount_faces) > NGLOB2DMAX_XY) &
+ call exit_MPI(myrank,'incorrect nb of points in face buffer')
+ do ipoin2D = 1,npoin2D_faces(icount_faces)
+ read(IIN,*) iboolfaces(ipoin2D,icount_faces),xdummy,ydummy,zdummy
+ enddo
+ close(IIN)
+ endif
+ enddo
+
+
+!---- read indirect addressing for each message for corners of the chunks
+!---- a given slice can belong to at most one corner
+ icount_corners = 0
+ do imsg = 1,NCORNERSCHUNKS
+ if(myrank == iproc_master_corners(imsg) .or. &
+ myrank == iproc_worker1_corners(imsg) .or. &
+ myrank == iproc_worker2_corners(imsg)) 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')
+
+! read file with 1D buffer for corner
+ if(myrank == iproc_master_corners(imsg)) then
+ write(filename,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
+ else if(myrank == iproc_worker1_corners(imsg)) then
+ write(filename,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
+ else if(myrank == iproc_worker2_corners(imsg)) then
+ write(filename,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
+ endif
+
+! matching codes
+ open(unit=IIN,file=prname(1:len_trim(prname))//filename,status='old',action='read')
+ read(IIN,*) npoin1D_corner
+ if(npoin1D_corner /= NGLOB1D_RADIAL) &
+ call exit_MPI(myrank,'incorrect nb of points in corner buffer')
+ do ipoin1D = 1,npoin1D_corner
+ read(IIN,*) iboolcorner(ipoin1D,icount_corners),xdummy,ydummy,zdummy
+ enddo
+ close(IIN)
+ endif
+ enddo
+
+ endif
+
+ end subroutine read_arrays_buffers_solver
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_arrays_solver.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/read_arrays_solver.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_arrays_solver.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_arrays_solver.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,197 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! read arrays created by the mesher
+
+ subroutine read_arrays_solver(iregion_code,myrank, &
+ rho_vp,rho_vs,xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ rhostore, kappavstore,muvstore,kappahstore,muhstore,eta_anisostore, &
+ nspec_iso,nspec_tiso,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,is_on_a_slice_edge,rmass,rmass_ocean_load,nspec,nglob, &
+ READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS,LOCAL_PATH,ABSORBING_CONDITIONS)
+
+ implicit none
+
+ include "constants.h"
+
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer iregion_code,myrank
+
+! flags to know if we should read Vs and anisotropy arrays
+ logical READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS,ABSORBING_CONDITIONS
+
+ character(len=150) LOCAL_PATH
+
+ integer nspec,nglob
+
+ integer nspec_iso,nspec_tiso,nspec_ani
+
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+! material properties
+ real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec_iso)
+ real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec_iso)
+ real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec_iso)
+
+! additional arrays for anisotropy stored only where needed to save memory
+ real(kind=CUSTOM_REAL) kappahstore(NGLLX,NGLLY,NGLLZ,nspec_tiso)
+ real(kind=CUSTOM_REAL) muhstore(NGLLX,NGLLY,NGLLZ,nspec_tiso)
+ real(kind=CUSTOM_REAL) eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec_tiso)
+
+! additional arrays for full anisotropy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store,c34store, &
+ c35store,c36store,c44store,c45store,c46store,c55store,c56store,c66store
+
+! Stacey
+ real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec)
+
+! mass matrix and additional ocean load mass matrix
+ real(kind=CUSTOM_REAL), dimension(nglob) :: rmass,rmass_ocean_load
+
+! global addressing
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer, dimension(nspec) :: idoubling
+
+! this for non blocking MPI
+ logical, dimension(nspec) :: is_on_a_slice_edge
+
+! processor identification
+ character(len=150) prname
+
+! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//'solver_data_1.bin', &
+ status='old',action='read',form='unformatted')
+
+ read(IIN) xix
+ read(IIN) xiy
+ read(IIN) xiz
+ read(IIN) etax
+ read(IIN) etay
+ read(IIN) etaz
+ read(IIN) gammax
+ read(IIN) gammay
+ read(IIN) gammaz
+
+! model arrays
+ read(IIN) rhostore
+ read(IIN) kappavstore
+
+ if(READ_KAPPA_MU) read(IIN) muvstore
+
+! for anisotropy, gravity and rotation
+
+ if(TRANSVERSE_ISOTROPY .and. READ_TISO) then
+ read(IIN) kappahstore
+ read(IIN) muhstore
+ read(IIN) eta_anisostore
+ endif
+
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
+ read(IIN) c11store
+ read(IIN) c12store
+ read(IIN) c13store
+ read(IIN) c33store
+ read(IIN) c44store
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ read(IIN) c11store
+ read(IIN) c12store
+ read(IIN) c13store
+ read(IIN) c14store
+ read(IIN) c15store
+ read(IIN) c16store
+ read(IIN) c22store
+ read(IIN) c23store
+ read(IIN) c24store
+ read(IIN) c25store
+ read(IIN) c26store
+ read(IIN) c33store
+ read(IIN) c34store
+ read(IIN) c35store
+ read(IIN) c36store
+ read(IIN) c44store
+ read(IIN) c45store
+ read(IIN) c46store
+ read(IIN) c55store
+ read(IIN) c56store
+ read(IIN) c66store
+ endif
+
+! Stacey
+ if(ABSORBING_CONDITIONS) then
+
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ read(IIN) rho_vp
+ read(IIN) rho_vs
+ else if(iregion_code == IREGION_OUTER_CORE) then
+ read(IIN) rho_vp
+ endif
+
+ endif
+
+! mass matrix
+ read(IIN) rmass
+
+! read additional ocean load mass matrix
+ if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) read(IIN) rmass_ocean_load
+
+ close(IIN)
+
+! read coordinates of the mesh
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//'solver_data_2.bin', &
+ status='old',action='read',form='unformatted')
+ read(IIN) xstore
+ read(IIN) ystore
+ read(IIN) zstore
+
+ read(IIN) ibool
+
+ read(IIN) idoubling
+
+ read(IIN) is_on_a_slice_edge
+
+ close(IIN)
+
+ end subroutine read_arrays_solver
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_compute_parameters.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/read_compute_parameters.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_compute_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_compute_parameters.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,2374 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,&
+ MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top, &
+ this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube, &
+ HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,&
+ USE_BINARY_FOR_LARGE_FILE,EMULATE_ONLY,NOISE_TOMOGRAPHY)
+
+
+ implicit none
+
+ include "constants.h"
+
+
+! parameters read from parameter file
+ integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read,NOISE_TOMOGRAPHY
+
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
+ CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
+ HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM, &
+ MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,&
+ MOVIE_SOUTH_DEG,RECORD_LENGTH_IN_MINUTES
+
+ logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
+ MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+
+! parameters to be computed based upon parameters above read from file
+ integer NSTEP,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ double precision DT,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, &
+ RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
+
+ double precision MOVIE_TOP,MOVIE_BOTTOM,MOVIE_EAST,MOVIE_WEST,&
+ MOVIE_NORTH,MOVIE_SOUTH
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ONE_CRUST,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ ATTENUATION_3D,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE, &
+ EMULATE_ONLY
+
+ integer NEX_MAX
+
+ double precision ELEMENT_WIDTH
+
+ 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
+
+! for the cut doublingbrick improvement
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer :: last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
+ normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge
+ 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
+
+
+ ! reads in Par_file values
+ call read_parameter_file(OUTPUT_FILES,LOCAL_PATH,MODEL, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, &
+ NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
+ CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
+ HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM,RECORD_LENGTH_IN_MINUTES, &
+ MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,MOVIE_SOUTH_DEG,&
+ ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
+ MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION,ABSORBING_CONDITIONS,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,NOISE_TOMOGRAPHY)
+
+ ! converts values to radians
+ 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
+ ! converts movie top/bottom depths to radii
+ MOVIE_TOP = (R_EARTH_KM-MOVIE_TOP_KM)/R_EARTH_KM
+ MOVIE_BOTTOM = (R_EARTH_KM-MOVIE_BOTTOM_KM)/R_EARTH_KM
+
+ ! 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
+
+ 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
+
+ ! turns on/off corresponding 1-D/3-D model flags
+ ! and sets radius for each discontinuity and ocean density values
+ call get_model_parameters(MODEL,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ATTENUATION_3D, &
+ CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO, &
+ ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY, &
+ OCEANS,TOPOGRAPHY, &
+ ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R120,R220,R400,R600,R670,R771, &
+ RTOPDDOUBLEPRIME,RCMB,RICB,RMOHO_FICTITIOUS_IN_MESHER, &
+ R80_FICTITIOUS_IN_MESHER,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS)
+
+
+ ! sets time step size and number of layers
+ ! right distribution is determined based upon maximum value of NEX
+ NEX_MAX = max(NEX_XI,NEX_ETA)
+ call rcp_set_timestep_and_layers(DT,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD, &
+ NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,&
+ NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,R_CENTRAL_CUBE, &
+ NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
+ ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
+ ANISOTROPIC_INNER_CORE)
+
+ ! 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)
+
+!<YANGL
+ if ( NOISE_TOMOGRAPHY /= 0 ) NSTEP = 2*NSTEP-1 ! time steps needs to be doubled, due to +/- branches
+!>YANGL
+
+ ! 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
+ endif
+
+ ! 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)
+
+
+ ! checks parameters
+ call rcp_check_parameters(NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
+ NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
+ ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM)
+
+ ! 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.
+ 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
+
+ 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
+ call rcp_define_all_layers(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,&
+ RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
+ ONE_CRUST,ner,ratio_sampling_array,&
+ NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer, &
+ r_bottom,r_top,this_region_has_a_doubling,&
+ ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,&
+ elem_doubling_bottom_outer_core,&
+ DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
+ DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval,&
+ doubling_index,rmins,rmaxs)
+
+
+ ! calculates number of elements (NSPEC)
+ call rcp_count_elements(NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NPROC,&
+ NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ ner,ratio_sampling_array,this_region_has_a_doubling, &
+ ifirst_region,ilast_region,iter_region,iter_layer,&
+ doubling,tmp_sum,tmp_sum_xi,tmp_sum_eta, &
+ NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
+ nb_lay_sb, nspec_sb, nglob_surf, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, INCLUDE_CENTRAL_CUBE, &
+ last_doubling_layer, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,&
+ nglob_edge_v,to_remove)
+
+
+ ! calculates number of points (NGLOB)
+ call rcp_count_points(NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB,&
+ nblocks_xi,nblocks_eta,ner,ratio_sampling_array,&
+ this_region_has_a_doubling,&
+ ifirst_region, ilast_region, iter_region, iter_layer, &
+ doubling, padding, tmp_sum, &
+ INCLUDE_CENTRAL_CUBE,NER_TOP_CENTRAL_CUBE_ICB,NEX_XI, &
+ NUMBER_OF_MESH_LAYERS,layer_offset, &
+ nb_lay_sb, nglob_vol, nglob_surf, nglob_edge, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
+ normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
+
+
+
+ end subroutine read_compute_parameters
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine rcp_set_timestep_and_layers(DT,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD, &
+ NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,&
+ NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,R_CENTRAL_CUBE, &
+ NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
+ ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
+ ANISOTROPIC_INNER_CORE)
+
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
+
+ integer NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB
+
+ integer NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL
+
+ double precision DT
+ double precision R_CENTRAL_CUBE
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
+
+ logical ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL,ANISOTROPIC_INNER_CORE
+
+! local variables
+ integer multiplication_factor
+
+ !----
+ !---- 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
+ ! time step
+ DT = 0.252d0
+
+ ! attenuation period range
+ MIN_ATTENUATION_PERIOD = 30
+ MAX_ATTENUATION_PERIOD = 1500
+
+ ! number of element layers in each mesh region
+ 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
+
+ ! radius of central cube
+ 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
+
+ !> Hejun
+ ! avoids elongated elements below the 670-discontinuity,
+ ! since for model REFERENCE_MODEL_1DREF,
+ ! the 670-discontinuity is moved up to 650 km depth.
+ if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1DREF) then
+ NER_771_670 = NER_771_670 + 1
+ end if
+
+ !----
+ !---- 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
+ ! 1D models honor 1D spherical moho
+ if (.not. ONE_CRUST) then
+ ! case 1D + two crustal layers
+ if (NER_CRUST < 2 ) NER_CRUST = 2
+ ! makes time step smaller
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.20d0
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.20d0
+ endif
+ endif
+ else
+ ! 3D models: must have two element layers for crust
+ if (NER_CRUST < 2 ) NER_CRUST = 2
+ ! makes time step smaller
+ if(NEX_MAX*multiplication_factor <= 80) then
+ DT = 0.125d0
+ else 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( .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, CRUSTAL, &
+ HONOR_1D_SPHERICAL_MOHO, REFERENCE_1D_MODEL)
+
+ 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
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+
+ ! time step reductions are based on empirical values (..somehow)
+
+ ! following models need special attention, at least for global simulations:
+ if( NCHUNKS == 6 ) then
+
+ ! makes time step smaller for this ref model, otherwise becomes unstable in fluid
+ if (REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) &
+ DT = DT*(1.d0 - 0.3d0)
+
+ ! using inner core anisotropy, simulations might become unstable in solid
+ if( ANISOTROPIC_INNER_CORE ) then
+ ! DT = DT*(1.d0 - 0.1d0) not working yet...
+ stop 'anisotropic inner core - unstable feature, uncomment this line in read_compute_parameters.f90'
+ endif
+
+ endif
+
+ ! following models need special attention, regardless of number of chunks:
+ ! it makes the time step smaller for this ref model, otherwise becomes unstable in fluid
+ if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) &
+ DT = DT*(1.d0 - 0.8d0) ! *0.20d0
+
+
+ if( ITYPE_CRUSTAL_MODEL == ICRUST_CRUSTMAPS ) &
+ DT = DT*(1.d0 - 0.3d0)
+
+ ! decreases time step as otherwise the solution might become unstable for rougher/unsmoothed models
+ ! if( THREE_D_MODEL == THREE_D_MODEL_PPM ) &
+ ! DT = DT * (1.d0 - 0.2d0)
+
+ ! takes a 5% safety margin on the maximum stable time step
+ ! which was obtained by trial and error
+ DT = DT * (1.d0 - 0.05d0)
+
+ ! adapts number of element layers in crust and time step for regional simulations
+ if( REGIONAL_MOHO_MESH ) then
+ ! hard coded number of crustal element layers and time step
+
+ ! checks
+ if( NCHUNKS > 1 ) stop 'regional moho mesh: NCHUNKS error in rcp_set_timestep_and_layers'
+ if( HONOR_1D_SPHERICAL_MOHO ) return
+
+ ! original values
+ !print*,'NER:',NER_CRUST
+ !print*,'DT:',DT
+
+ ! enforce 3 element layers
+ NER_CRUST = 3
+
+ ! increased stability, empirical
+ DT = DT*(1.d0 + 0.5d0)
+
+ if( REGIONAL_MOHO_MESH_EUROPE ) DT = 0.14 ! europe
+ if( REGIONAL_MOHO_MESH_ASIA ) DT = 0.15 ! asia & middle east
+
+ endif
+
+
+ end subroutine rcp_set_timestep_and_layers
+
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine rcp_check_parameters(NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
+ NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
+ ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM)
+
+ implicit none
+
+ include "constants.h"
+
+ integer NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA,NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS
+
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
+
+ logical ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS,&
+ INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM
+
+
+! checks parameters
+
+ if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
+ stop 'NCHUNKS must be either 1, 2, 3 or 6'
+
+ ! 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'
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS == 6) &
+ stop 'cannot have absorbing conditions in the full Earth'
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS == 3) &
+ stop 'absorbing conditions not supported for three chunks yet'
+
+ if(ATTENUATION_3D .and. .not. ATTENUATION) &
+ stop 'need ATTENUATION to use ATTENUATION_3D'
+
+ if (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'
+
+ ! 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 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'
+
+ ! support for only one slice per chunk has been discontinued when there is more than one chunk
+ ! because it induces topological problems, and we are not interested in using small meshes
+ if(NCHUNKS > 1 .and. (NPROC_XI == 1 .or. NPROC_ETA == 1)) stop 'support for only one slice per chunk has been discontinued'
+
+ end subroutine rcp_check_parameters
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine rcp_define_all_layers(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,&
+ RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
+ ONE_CRUST,ner,ratio_sampling_array,&
+ NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer, &
+ r_bottom,r_top,this_region_has_a_doubling,&
+ ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,&
+ elem_doubling_bottom_outer_core,&
+ DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
+ DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval,&
+ doubling_index,rmins,rmaxs)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! definition of general mesh parameters below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB
+ integer NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer
+
+ double precision RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
+
+ logical ONE_CRUST
+
+ 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
+
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+
+
+! 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
+
+ ! default case:
+ ! no fourth doubling at the bottom of the outer core
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+
+ ! suppress the crustal layers
+ ! will be replaced by an extension of the mantle: R_EARTH is not modified,
+ ! but no more crustal doubling
+
+ 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.
+ last_doubling_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_FICTITIOUS_IN_MESHER
+
+ 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_FICTITIOUS_IN_MESHER !!!! now fictitious
+
+ r_top(4) = R80_FICTITIOUS_IN_MESHER
+ 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_FICTITIOUS_IN_MESHER / 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_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+
+ rmaxs(4) = R80_FICTITIOUS_IN_MESHER / 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
+
+ ! 1D models:
+ ! 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.
+
+ 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.
+ last_doubling_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_FICTITIOUS_IN_MESHER
+
+ r_top(3) = R80_FICTITIOUS_IN_MESHER
+ 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_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(3) = R80_FICTITIOUS_IN_MESHER / 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
+
+ ! default case for 3D models:
+ ! contains the crustal layers
+ ! doubling at the base of the crust
+
+ 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) ! regional mesh: ner(1) = 1 since NER_CRUST=3
+ ner( 2) = ceiling (NER_CRUST / 2.d0) ! ner(2) = 2
+ 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.
+ last_doubling_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_FICTITIOUS_IN_MESHER
+
+ r_top(4) = R80_FICTITIOUS_IN_MESHER
+ 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_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(4) = R80_FICTITIOUS_IN_MESHER / 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
+
+ ! 4th doubling case:
+ ! includes fourth doubling at the bottom of the outer core
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+
+ ! suppress the crustal layers
+ ! will be replaced by an extension of the mantle: R_EARTH is not modified,
+ ! but no more crustal doubling
+
+ 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.
+ last_doubling_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_FICTITIOUS_IN_MESHER
+
+ 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_FICTITIOUS_IN_MESHER !!!! now fictitious
+
+ r_top(4) = R80_FICTITIOUS_IN_MESHER
+ 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_FICTITIOUS_IN_MESHER / 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_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+
+ rmaxs(4) = R80_FICTITIOUS_IN_MESHER / 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
+
+ ! 1D models:
+ ! 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.
+
+ 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.
+ last_doubling_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_FICTITIOUS_IN_MESHER
+
+ r_top(3) = R80_FICTITIOUS_IN_MESHER
+ 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_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(3) = R80_FICTITIOUS_IN_MESHER / 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
+
+ ! for 3D models:
+ ! contains the crustal layers
+ ! doubling at the base of the crust
+
+ 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.
+ last_doubling_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_FICTITIOUS_IN_MESHER
+
+ r_top(4) = R80_FICTITIOUS_IN_MESHER
+ 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_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(4) = R80_FICTITIOUS_IN_MESHER / 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
+
+
+ end subroutine rcp_define_all_layers
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine rcp_count_elements(NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NPROC,&
+ NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ ner,ratio_sampling_array,this_region_has_a_doubling, &
+ ifirst_region,ilast_region,iter_region,iter_layer, &
+ doubling,tmp_sum,tmp_sum_xi,tmp_sum_eta, &
+ NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
+ nb_lay_sb, nspec_sb, nglob_surf, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, INCLUDE_CENTRAL_CUBE, &
+ last_doubling_layer, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,&
+ nglob_edge_v,to_remove)
+
+
+ implicit none
+
+ include "constants.h"
+
+
+! parameters to be computed based upon parameters above read from file
+ integer NPROC,NEX_XI,NEX_ETA,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,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+
+
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+
+
+ integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, tmp_sum, tmp_sum_xi, tmp_sum_eta
+ integer :: NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
+ nb_lay_sb, nspec_sb, nglob_surf
+
+
+! for the cut doublingbrick improvement
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ logical :: INCLUDE_CENTRAL_CUBE
+ integer :: last_doubling_layer
+ 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
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! calculation of number of elements (NSPEC) below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ratio_divide_central_cube = maxval(ratio_sampling_array(1:NUMBER_OF_MESH_LAYERS))
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 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 == last_doubling_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
+ divider = 1
+ doubling = 0
+ nb_lay_sb = 0
+ nspec2D_xi_sb = 0
+ nspec2D_eta_sb = 0
+ 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 ! iter_layer
+
+ 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 ! iter_region
+
+ ! 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, try to recompile :) '
+
+
+ end subroutine rcp_count_elements
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine rcp_count_points(NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB,&
+ nblocks_xi,nblocks_eta,ner,ratio_sampling_array,&
+ this_region_has_a_doubling,&
+ ifirst_region, ilast_region, iter_region, iter_layer, &
+ doubling, padding, tmp_sum, &
+ INCLUDE_CENTRAL_CUBE,NER_TOP_CENTRAL_CUBE_ICB,NEX_XI, &
+ NUMBER_OF_MESH_LAYERS,layer_offset, &
+ nb_lay_sb, nglob_vol, nglob_surf, nglob_edge, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
+ normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! calculation of number of points (NGLOB) below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+
+! parameters to be computed based upon parameters above read from file
+ integer NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, dimension(MAX_NUM_REGIONS) :: &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB
+
+ integer NER_TOP_CENTRAL_CUBE_ICB,NEX_XI
+ integer nblocks_xi,nblocks_eta
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+
+ integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, padding, tmp_sum
+ integer :: NUMBER_OF_MESH_LAYERS,layer_offset, &
+ nb_lay_sb, nglob_vol, nglob_surf, nglob_edge
+
+! for the cut doublingbrick improvement
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,INCLUDE_CENTRAL_CUBE
+ integer :: last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
+ normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 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 == last_doubling_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 rcp_count_points
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_forward_arrays.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/read_forward_arrays.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_forward_arrays.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_forward_arrays.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,249 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine read_forward_arrays_startrun(myrank,NSTEP, &
+ SIMULATION_TYPE,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
+ it_begin,it_end, &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
+ displ_inner_core,veloc_inner_core,accel_inner_core, &
+ displ_outer_core,veloc_outer_core,accel_outer_core, &
+ R_memory_crust_mantle,R_memory_inner_core, &
+ epsilondev_crust_mantle,epsilondev_inner_core, &
+ A_array_rotation,B_array_rotation, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+ b_R_memory_crust_mantle,b_R_memory_inner_core, &
+ b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+
+! reads in saved wavefields
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank,NSTEP
+
+ integer SIMULATION_TYPE
+
+ integer NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,it_begin,it_end
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
+ displ_inner_core,veloc_inner_core,accel_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
+ displ_outer_core,veloc_outer_core,accel_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: &
+ R_memory_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
+ epsilondev_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
+ R_memory_inner_core
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: &
+ epsilondev_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
+ A_array_rotation,B_array_rotation
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: &
+ b_R_memory_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ b_epsilondev_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: &
+ b_R_memory_inner_core
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
+ b_epsilondev_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
+ b_A_array_rotation,b_B_array_rotation
+
+ character(len=150) LOCAL_PATH
+
+ !local parameters
+ character(len=150) outputname
+
+ ! define correct time steps if restart files
+ if(NUMBER_OF_RUNS < 1 .or. NUMBER_OF_RUNS > 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'
+
+ if(NUMBER_OF_RUNS == 3) then
+ if(NUMBER_OF_THIS_RUN == 1) then
+ it_begin = 1
+ it_end = NSTEP/3
+ else if(NUMBER_OF_THIS_RUN == 2) then
+ it_begin = NSTEP/3 + 1
+ it_end = 2*(NSTEP/3)
+ else
+ it_begin = 2*(NSTEP/3) + 1
+ it_end = NSTEP
+ endif
+
+ else if(NUMBER_OF_RUNS == 2) then
+ if(NUMBER_OF_THIS_RUN == 1) then
+ it_begin = 1
+ it_end = NSTEP/2
+ else
+ it_begin = NSTEP/2 + 1
+ it_end = NSTEP
+ endif
+
+ else
+ it_begin = 1
+ it_end = NSTEP
+ endif
+
+ ! read files back from local disk or MT tape system if restart file
+ if(NUMBER_OF_THIS_RUN > 1) then
+ write(outputname,"('dump_all_arrays',i6.6)") myrank
+ open(unit=55,file=trim(LOCAL_PATH)//'/'//outputname,status='old',action='read',form='unformatted')
+ read(55) displ_crust_mantle
+ read(55) veloc_crust_mantle
+ read(55) accel_crust_mantle
+ read(55) displ_inner_core
+ read(55) veloc_inner_core
+ read(55) accel_inner_core
+ read(55) displ_outer_core
+ read(55) veloc_outer_core
+ read(55) accel_outer_core
+ read(55) epsilondev_crust_mantle
+ read(55) epsilondev_inner_core
+ read(55) A_array_rotation
+ read(55) B_array_rotation
+ read(55) R_memory_crust_mantle
+ read(55) R_memory_inner_core
+ close(55)
+ endif
+
+ if (SIMULATION_TYPE == 3) then
+ ! initializes
+ b_displ_crust_mantle = 0._CUSTOM_REAL
+ b_veloc_crust_mantle = 0._CUSTOM_REAL
+ b_accel_crust_mantle = 0._CUSTOM_REAL
+ b_displ_inner_core = 0._CUSTOM_REAL
+ b_veloc_inner_core = 0._CUSTOM_REAL
+ b_accel_inner_core = 0._CUSTOM_REAL
+ b_displ_outer_core = 0._CUSTOM_REAL
+ b_veloc_outer_core = 0._CUSTOM_REAL
+ b_accel_outer_core = 0._CUSTOM_REAL
+ b_epsilondev_crust_mantle = 0._CUSTOM_REAL
+ b_epsilondev_inner_core = 0._CUSTOM_REAL
+ if (ROTATION_VAL) then
+ b_A_array_rotation = 0._CUSTOM_REAL
+ b_B_array_rotation = 0._CUSTOM_REAL
+ endif
+ if (ATTENUATION_VAL) then
+ b_R_memory_crust_mantle = 0._CUSTOM_REAL
+ b_R_memory_inner_core = 0._CUSTOM_REAL
+ endif
+ endif
+
+ end subroutine read_forward_arrays_startrun
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_forward_arrays(myrank, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+ b_R_memory_crust_mantle,b_R_memory_inner_core, &
+ b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+
+! reads in saved wavefields
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ ! backward/reconstructed wavefields
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: &
+ b_R_memory_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ b_epsilondev_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: &
+ b_R_memory_inner_core
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
+ b_epsilondev_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
+ b_A_array_rotation,b_B_array_rotation
+
+ character(len=150) LOCAL_PATH
+
+ !local parameters
+ character(len=150) outputname
+
+ write(outputname,'(a,i6.6,a)') 'proc',myrank,'_save_forward_arrays.bin'
+ open(unit=55,file=trim(LOCAL_PATH)//'/'//outputname,status='old',action='read',form='unformatted')
+ read(55) b_displ_crust_mantle
+ read(55) b_veloc_crust_mantle
+ read(55) b_accel_crust_mantle
+ read(55) b_displ_inner_core
+ read(55) b_veloc_inner_core
+ read(55) b_accel_inner_core
+ read(55) b_displ_outer_core
+ read(55) b_veloc_outer_core
+ read(55) b_accel_outer_core
+ read(55) b_epsilondev_crust_mantle
+ read(55) b_epsilondev_inner_core
+ if (ROTATION_VAL) then
+ read(55) b_A_array_rotation
+ read(55) b_B_array_rotation
+ endif
+ if (ATTENUATION_VAL) then
+ read(55) b_R_memory_crust_mantle
+ read(55) b_R_memory_inner_core
+ endif
+ close(55)
+
+ end subroutine read_forward_arrays
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_mesh_databases.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/read_mesh_databases.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_mesh_databases.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_mesh_databases.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,1012 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine read_mesh_databases(myrank,rho_vp_crust_mantle,rho_vs_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, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ nspec_iso,nspec_tiso,nspec_ani, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle,is_on_a_slice_edge_crust_mantle,rmass_crust_mantle,rmass_ocean_load, &
+ vp_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, &
+ rhostore_outer_core,kappavstore_outer_core, &
+ ibool_outer_core,idoubling_outer_core,is_on_a_slice_edge_outer_core,rmass_outer_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
+ c11store_inner_core,c12store_inner_core,c13store_inner_core, &
+ c33store_inner_core,c44store_inner_core, &
+ ibool_inner_core,idoubling_inner_core,is_on_a_slice_edge_inner_core,rmass_inner_core, &
+ ABSORBING_CONDITIONS,LOCAL_PATH)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ ! Stacey
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: &
+ rho_vp_crust_mantle,rho_vs_crust_mantle
+
+ ! mesh parameters
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle
+ ! arrays for anisotropic elements stored only where needed to save space
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
+
+ ! arrays for full anisotropy only when needed
+ 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, &
+ 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
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
+ ! mass matrix
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
+ ! additional mass matrix for ocean load
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
+
+ ! stacy outer core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_STACEY) :: vp_outer_core
+ ! mesh parameters
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
+ 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(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
+ rhostore_outer_core,kappavstore_outer_core
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+ integer, dimension(NSPEC_OUTER_CORE) :: idoubling_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_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, &
+ rhostore_inner_core, kappavstore_inner_core,muvstore_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core
+ 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
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
+
+ logical ABSORBING_CONDITIONS
+ character(len=150) LOCAL_PATH
+
+ !local parameters
+ logical READ_KAPPA_MU,READ_TISO
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,1) :: dummy_array
+
+! this for non blocking MPI
+ logical, dimension(NSPEC_CRUST_MANTLE) :: is_on_a_slice_edge_crust_mantle
+ logical, dimension(NSPEC_OUTER_CORE) :: is_on_a_slice_edge_outer_core
+ logical, dimension(NSPEC_INNER_CORE) :: is_on_a_slice_edge_inner_core
+
+ ! 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
+ call read_arrays_solver(IREGION_CRUST_MANTLE,myrank, &
+ rho_vp_crust_mantle,rho_vs_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, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ nspec_iso,nspec_tiso,nspec_ani, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle,is_on_a_slice_edge_crust_mantle,rmass_crust_mantle,rmass_ocean_load, &
+ NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
+ READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY_VAL,ANISOTROPIC_3D_MANTLE_VAL, &
+ ANISOTROPIC_INNER_CORE_VAL,OCEANS_VAL,LOCAL_PATH,ABSORBING_CONDITIONS)
+
+ ! 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
+
+ call read_arrays_solver(IREGION_OUTER_CORE,myrank, &
+ vp_outer_core,dummy_array, &
+ 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, &
+ rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ nspec_iso,nspec_tiso,nspec_ani, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ ibool_outer_core,idoubling_outer_core,is_on_a_slice_edge_outer_core,rmass_outer_core,rmass_ocean_load, &
+ NSPEC_OUTER_CORE,NGLOB_OUTER_CORE, &
+ READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY_VAL,ANISOTROPIC_3D_MANTLE_VAL, &
+ ANISOTROPIC_INNER_CORE_VAL,OCEANS_VAL,LOCAL_PATH,ABSORBING_CONDITIONS)
+
+ ! 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
+
+ call read_arrays_solver(IREGION_INNER_CORE,myrank, &
+ dummy_array,dummy_array, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
+ dummy_array,dummy_array,dummy_array, &
+ nspec_iso,nspec_tiso,nspec_ani, &
+ c11store_inner_core,c12store_inner_core,c13store_inner_core, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,c33store_inner_core, &
+ dummy_array,dummy_array,dummy_array, &
+ c44store_inner_core,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ ibool_inner_core,idoubling_inner_core,is_on_a_slice_edge_inner_core,rmass_inner_core,rmass_ocean_load, &
+ NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
+ READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY_VAL,ANISOTROPIC_3D_MANTLE_VAL, &
+ ANISOTROPIC_INNER_CORE_VAL,OCEANS_VAL,LOCAL_PATH,ABSORBING_CONDITIONS)
+
+ ! 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')
+
+ end subroutine read_mesh_databases
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine read_mesh_databases_addressing(myrank, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, &
+ iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,npoin2D_faces_crust_mantle, &
+ iboolcorner_crust_mantle, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core, &
+ iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_xi_outer_core,npoin2D_eta_outer_core,&
+ iboolfaces_outer_core,npoin2D_faces_outer_core, &
+ iboolcorner_outer_core, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core, &
+ iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,npoin2D_faces_inner_core, &
+ iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ LOCAL_PATH,OUTPUT_FILES, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XY,NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
+ ichunk,iproc_xi,iproc_eta)
+
+ implicit none
+
+ include 'mpif.h'
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ ! 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
+
+ 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
+
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle, &
+ iboolfaces_outer_core,iboolfaces_inner_core
+
+ integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer npoin2D_faces_outer_core(NUMFACES_SHARED)
+ integer npoin2D_faces_inner_core(NUMFACES_SHARED)
+
+ ! 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
+
+ ! 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
+
+ character(len=150) LOCAL_PATH,OUTPUT_FILES
+
+ integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+ integer NGLOB2DMAX_XY
+
+ integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS
+
+ ! 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
+ integer ichunk,iproc_xi,iproc_eta
+
+ ! local parameters
+ integer :: ier,iproc,iproc_read
+ integer :: NUM_FACES,NPROC_ONE_DIRECTION
+
+ ! open file with global slice number addressing
+ if(myrank == 0) then
+ open(unit=IIN,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening addressing.txt')
+ do iproc = 0,NPROCTOT_VAL-1
+ read(IIN,*) iproc_read,ichunk,iproc_xi,iproc_eta
+ if(iproc_read /= iproc) call exit_MPI(myrank,'incorrect slice number read')
+ addressing(ichunk,iproc_xi,iproc_eta) = iproc
+ ichunk_slice(iproc) = ichunk
+ iproc_xi_slice(iproc) = iproc_xi
+ iproc_eta_slice(iproc) = iproc_eta
+ enddo
+ close(IIN)
+ endif
+
+ ! broadcast the information read on the master to the nodes
+ call MPI_BCAST(addressing,NCHUNKS_VAL*NPROC_XI_VAL*NPROC_ETA_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ichunk_slice,NPROCTOT_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iproc_xi_slice,NPROCTOT_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iproc_eta_slice,NPROCTOT_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ ! output a topology map of slices - fix 20x by nproc
+ if (myrank == 0 .and. NCHUNKS_VAL == 6) then
+ write(IMAIN,*) 'Spatial distribution of the slices'
+ do iproc_xi = NPROC_XI_VAL-1, 0, -1
+ write(IMAIN,'(20x)',advance='no')
+ do iproc_eta = NPROC_ETA_VAL -1, 0, -1
+ ichunk = CHUNK_AB
+ write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
+ enddo
+ write(IMAIN,'(1x)',advance='yes')
+ enddo
+ write(IMAIN, *) ' '
+ do iproc_xi = NPROC_XI_VAL-1, 0, -1
+ write(IMAIN,'(1x)',advance='no')
+ do iproc_eta = NPROC_ETA_VAL -1, 0, -1
+ ichunk = CHUNK_BC
+ write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
+ enddo
+ write(IMAIN,'(3x)',advance='no')
+ do iproc_eta = NPROC_ETA_VAL -1, 0, -1
+ ichunk = CHUNK_AC
+ write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
+ enddo
+ write(IMAIN,'(3x)',advance='no')
+ do iproc_eta = NPROC_ETA_VAL -1, 0, -1
+ ichunk = CHUNK_BC_ANTIPODE
+ write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
+ enddo
+ write(IMAIN,'(1x)',advance='yes')
+ enddo
+ write(IMAIN, *) ' '
+ do iproc_xi = NPROC_XI_VAL-1, 0, -1
+ write(IMAIN,'(20x)',advance='no')
+ do iproc_eta = NPROC_ETA_VAL -1, 0, -1
+ ichunk = CHUNK_AB_ANTIPODE
+ write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
+ enddo
+ write(IMAIN,'(1x)',advance='yes')
+ enddo
+ write(IMAIN, *) ' '
+ do iproc_xi = NPROC_XI_VAL-1, 0, -1
+ write(IMAIN,'(20x)',advance='no')
+ do iproc_eta = NPROC_ETA_VAL -1, 0, -1
+ ichunk = CHUNK_AC_ANTIPODE
+ write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
+ enddo
+ write(IMAIN,'(1x)',advance='yes')
+ enddo
+ write(IMAIN, *) ' '
+ endif
+
+ ! 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)
+
+ ! define maximum size for message buffers
+ ! use number of elements found in the mantle since it is the largest region
+ NGLOB2DMAX_XY = max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE))
+
+ ! 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_VAL
+ ! total number of messages corresponding to these common faces
+ NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
+
+
+ ! read 2-D addressing for summation between slices with MPI
+
+ ! mantle and crust
+ call read_arrays_buffers_solver(IREGION_CRUST_MANTLE,myrank,iboolleft_xi_crust_mantle, &
+ iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_crust_mantle,npoin2D_faces_crust_mantle, &
+ iboolcorner_crust_mantle, &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT_VAL,NPROC_XI_VAL,NPROC_ETA_VAL,LOCAL_PATH,NCHUNKS_VAL)
+
+ ! outer core
+ call read_arrays_buffers_solver(IREGION_OUTER_CORE,myrank, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_outer_core,npoin2D_faces_outer_core, &
+ iboolcorner_outer_core, &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT_VAL,NPROC_XI_VAL,NPROC_ETA_VAL,LOCAL_PATH,NCHUNKS_VAL)
+
+ ! inner core
+ call read_arrays_buffers_solver(IREGION_INNER_CORE,myrank, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_inner_core,npoin2D_faces_inner_core, &
+ iboolcorner_inner_core, &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE), &
+ NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE),NGLOB2DMAX_XY,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
+ NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT_VAL,NPROC_XI_VAL,NPROC_ETA_VAL,LOCAL_PATH,NCHUNKS_VAL)
+
+
+ end subroutine read_mesh_databases_addressing
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_mesh_databases_coupling(myrank, &
+ 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, &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle,normal_ymin_crust_mantle, &
+ normal_ymax_crust_mantle,normal_bottom_crust_mantle,normal_top_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle,jacobian2D_ymin_crust_mantle, &
+ jacobian2D_ymax_crust_mantle,jacobian2D_bottom_crust_mantle,jacobian2D_top_crust_mantle, &
+ 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, &
+ normal_xmin_outer_core,normal_xmax_outer_core,normal_ymin_outer_core, &
+ normal_ymax_outer_core,normal_bottom_outer_core,normal_top_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core,jacobian2D_ymin_outer_core, &
+ jacobian2D_ymax_outer_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
+ 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, &
+ ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
+ ibelm_670_top,ibelm_670_bot,normal_moho,normal_400,normal_670, &
+ k_top,k_bot,moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl, &
+ LOCAL_PATH,SIMULATION_TYPE)
+
+! to couple mantle with outer core
+ implicit none
+
+ include 'mpif.h'
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ ! for crust/oceans coupling
+ integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
+ integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: jacobian2D_bottom_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: jacobian2D_top_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_CM) :: &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2DMAX_YMIN_YMAX_CM) :: &
+ normal_ymin_crust_mantle,normal_ymax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: normal_bottom_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
+
+ ! arrays to couple with the fluid regions by pointwise matching
+ integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+ integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core
+ 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
+
+ ! inner core
+ integer nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
+ nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
+ integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
+
+ ! boundary
+ integer, dimension(NSPEC2D_MOHO) :: ibelm_moho_top,ibelm_moho_bot
+ integer, dimension(NSPEC2D_400) :: ibelm_400_top,ibelm_400_bot
+ integer, dimension(NSPEC2D_670) :: ibelm_670_top,ibelm_670_bot
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO) :: normal_moho
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_400) :: normal_400
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_670) :: normal_670
+
+ integer k_top,k_bot
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO) :: moho_kl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_400) :: d400_kl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_670) :: d670_kl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_CMB) :: cmb_kl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_ICB) :: icb_kl
+
+ character(len=150) LOCAL_PATH
+ integer SIMULATION_TYPE
+
+ ! local parameters
+ integer njunk1,njunk2,njunk3
+ character(len=150) prname
+
+
+ ! crust and mantle
+ ! create name of database
+ call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
+
+ ! Stacey put back
+ open(unit=27,file=prname(1:len_trim(prname))//'boundary.bin', &
+ status='old',form='unformatted',action='read')
+ read(27) nspec2D_xmin_crust_mantle
+ read(27) nspec2D_xmax_crust_mantle
+ read(27) nspec2D_ymin_crust_mantle
+ read(27) nspec2D_ymax_crust_mantle
+ read(27) njunk1
+ read(27) njunk2
+
+! boundary parameters
+ read(27) ibelm_xmin_crust_mantle
+ read(27) ibelm_xmax_crust_mantle
+ read(27) ibelm_ymin_crust_mantle
+ read(27) ibelm_ymax_crust_mantle
+ read(27) ibelm_bottom_crust_mantle
+ read(27) ibelm_top_crust_mantle
+
+ read(27) normal_xmin_crust_mantle
+ read(27) normal_xmax_crust_mantle
+ read(27) normal_ymin_crust_mantle
+ read(27) normal_ymax_crust_mantle
+ read(27) normal_bottom_crust_mantle
+ read(27) normal_top_crust_mantle
+
+ read(27) jacobian2D_xmin_crust_mantle
+ read(27) jacobian2D_xmax_crust_mantle
+ read(27) jacobian2D_ymin_crust_mantle
+ read(27) jacobian2D_ymax_crust_mantle
+ read(27) jacobian2D_bottom_crust_mantle
+ read(27) jacobian2D_top_crust_mantle
+ close(27)
+
+
+ ! read parameters to couple fluid and solid regions
+ !
+ ! outer core
+
+ ! create name of database
+ call create_name_database(prname,myrank,IREGION_OUTER_CORE,LOCAL_PATH)
+
+ ! boundary parameters
+
+ ! Stacey put back
+ open(unit=27,file=prname(1:len_trim(prname))//'boundary.bin', &
+ status='old',form='unformatted',action='read')
+ read(27) nspec2D_xmin_outer_core
+ read(27) nspec2D_xmax_outer_core
+ read(27) nspec2D_ymin_outer_core
+ read(27) nspec2D_ymax_outer_core
+ read(27) njunk1
+ read(27) njunk2
+
+ read(27) ibelm_xmin_outer_core
+ read(27) ibelm_xmax_outer_core
+ read(27) ibelm_ymin_outer_core
+ read(27) ibelm_ymax_outer_core
+ read(27) ibelm_bottom_outer_core
+ read(27) ibelm_top_outer_core
+
+ read(27) normal_xmin_outer_core
+ read(27) normal_xmax_outer_core
+ read(27) normal_ymin_outer_core
+ read(27) normal_ymax_outer_core
+ read(27) normal_bottom_outer_core
+ read(27) normal_top_outer_core
+
+ read(27) jacobian2D_xmin_outer_core
+ read(27) jacobian2D_xmax_outer_core
+ read(27) jacobian2D_ymin_outer_core
+ read(27) jacobian2D_ymax_outer_core
+ read(27) jacobian2D_bottom_outer_core
+ read(27) jacobian2D_top_outer_core
+ close(27)
+
+
+ !
+ ! inner core
+ !
+
+ ! create name of database
+ call create_name_database(prname,myrank,IREGION_INNER_CORE,LOCAL_PATH)
+
+ ! read info for vertical edges for central cube matching in inner core
+ open(unit=27,file=prname(1:len_trim(prname))//'boundary.bin', &
+ status='old',form='unformatted',action='read')
+ read(27) nspec2D_xmin_inner_core
+ read(27) nspec2D_xmax_inner_core
+ read(27) nspec2D_ymin_inner_core
+ read(27) nspec2D_ymax_inner_core
+ read(27) njunk1
+ read(27) njunk2
+
+ ! boundary parameters
+ read(27) ibelm_xmin_inner_core
+ read(27) ibelm_xmax_inner_core
+ read(27) ibelm_ymin_inner_core
+ read(27) ibelm_ymax_inner_core
+ read(27) ibelm_bottom_inner_core
+ read(27) ibelm_top_inner_core
+ close(27)
+
+
+ ! -- Boundary Mesh for crust and mantle ---
+ if (SAVE_BOUNDARY_MESH .and. SIMULATION_TYPE == 3) then
+
+ call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
+
+ open(unit=27,file=prname(1:len_trim(prname))//'boundary_disc.bin', &
+ status='old',form='unformatted',action='read')
+ read(27) njunk1,njunk2,njunk3
+ if (njunk1 /= NSPEC2D_MOHO .and. njunk2 /= NSPEC2D_400 .and. njunk3 /= NSPEC2D_670) &
+ call exit_mpi(myrank, 'Error reading ibelm_disc.bin file')
+ read(27) ibelm_moho_top
+ read(27) ibelm_moho_bot
+ read(27) ibelm_400_top
+ read(27) ibelm_400_bot
+ read(27) ibelm_670_top
+ read(27) ibelm_670_bot
+ read(27) normal_moho
+ read(27) normal_400
+ read(27) normal_670
+ close(27)
+
+ k_top = 1
+ k_bot = NGLLZ
+
+ ! initialization
+ moho_kl = 0.; d400_kl = 0.; d670_kl = 0.; cmb_kl = 0.; icb_kl = 0.
+ endif
+
+ end subroutine read_mesh_databases_coupling
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine read_mesh_databases_stacey(myrank, &
+ nimin_crust_mantle,nimax_crust_mantle,njmin_crust_mantle, &
+ njmax_crust_mantle,nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nimin_outer_core,nimax_outer_core,njmin_outer_core, &
+ njmax_outer_core,nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ reclen_zmin,NSPEC2D_BOTTOM, &
+ SIMULATION_TYPE,SAVE_FORWARD,LOCAL_PATH,NSTEP)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_CM) :: &
+ nimin_crust_mantle,nimax_crust_mantle,nkmin_eta_crust_mantle
+ integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_CM) :: &
+ njmin_crust_mantle,njmax_crust_mantle,nkmin_xi_crust_mantle
+ integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
+ integer reclen_xmin_crust_mantle, reclen_xmax_crust_mantle, reclen_ymin_crust_mantle, &
+ reclen_ymax_crust_mantle
+
+ integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_OC) :: nimin_outer_core,nimax_outer_core,nkmin_eta_outer_core
+ integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_OC) :: njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core
+ integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
+ integer reclen_xmin_outer_core, reclen_xmax_outer_core,reclen_ymin_outer_core, &
+ reclen_ymax_outer_core
+
+ integer reclen_zmin
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_BOTTOM
+
+ integer SIMULATION_TYPE
+ logical SAVE_FORWARD
+ character(len=150) LOCAL_PATH
+ integer NSTEP
+
+ ! local parameters
+ character(len=150) prname
+
+
+ ! crust and mantle
+ ! create name of database
+ call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
+
+ ! read arrays for Stacey conditions
+ open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin', &
+ status='old',form='unformatted',action='read')
+ read(27) nimin_crust_mantle
+ read(27) nimax_crust_mantle
+ read(27) njmin_crust_mantle
+ read(27) njmax_crust_mantle
+ read(27) nkmin_xi_crust_mantle
+ read(27) nkmin_eta_crust_mantle
+ close(27)
+
+ if (nspec2D_xmin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ reclen_xmin_crust_mantle = CUSTOM_REAL * (NDIM * NGLLY * NGLLZ * nspec2D_xmin_crust_mantle)
+ if (SIMULATION_TYPE == 3) then
+! open(unit=51,file=trim(prname)//'absorb_xmin.bin', &
+! status='old',action='read',form='unformatted',access='direct', &
+! recl=reclen_xmin_crust_mantle+2*4)
+! else
+! open(unit=51,file=trim(prname)//'absorb_xmin.bin', &
+! status='unknown',form='unformatted',access='direct',&
+! recl=reclen_xmin_crust_mantle+2*4)
+
+ call open_file_abs_r(0,trim(prname)//'absorb_xmin.bin',len_trim(trim(prname)//'absorb_xmin.bin'), &
+ reclen_xmin_crust_mantle*NSTEP)
+ else
+ call open_file_abs_w(0,trim(prname)//'absorb_xmin.bin',len_trim(trim(prname)//'absorb_xmin.bin'), &
+ reclen_xmin_crust_mantle*NSTEP)
+ endif
+ endif
+
+ if (nspec2D_xmax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ reclen_xmax_crust_mantle = CUSTOM_REAL * (NDIM * NGLLY * NGLLZ * nspec2D_xmax_crust_mantle)
+ if (SIMULATION_TYPE == 3) then
+! open(unit=52,file=trim(prname)//'absorb_xmax.bin', &
+! status='old',action='read',form='unformatted',access='direct', &
+! recl=reclen_xmax_crust_mantle+2*4)
+! else
+! open(unit=52,file=trim(prname)//'absorb_xmax.bin', &
+! status='unknown',form='unformatted',access='direct', &
+! recl=reclen_xmax_crust_mantle+2*4)
+
+ call open_file_abs_r(1,trim(prname)//'absorb_xmax.bin',len_trim(trim(prname)//'absorb_xmax.bin'), &
+ reclen_xmax_crust_mantle*NSTEP)
+ else
+ call open_file_abs_w(1,trim(prname)//'absorb_xmax.bin',len_trim(trim(prname)//'absorb_xmax.bin'), &
+ reclen_xmax_crust_mantle*NSTEP)
+ endif
+ endif
+
+ if (nspec2D_ymin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ reclen_ymin_crust_mantle = CUSTOM_REAL * (NDIM * NGLLX * NGLLZ * nspec2D_ymin_crust_mantle)
+ if (SIMULATION_TYPE == 3) then
+! open(unit=53,file=trim(prname)//'absorb_ymin.bin', &
+! status='old',action='read',form='unformatted',access='direct',&
+! recl=reclen_ymin_crust_mantle+2*4)
+! else
+! open(unit=53,file=trim(prname)//'absorb_ymin.bin', &
+! status='unknown',form='unformatted',access='direct',&
+! recl=reclen_ymin_crust_mantle+2*4)
+
+ call open_file_abs_r(2,trim(prname)//'absorb_ymin.bin',len_trim(trim(prname)//'absorb_ymin.bin'), &
+ reclen_ymin_crust_mantle*NSTEP)
+ else
+ call open_file_abs_w(2,trim(prname)//'absorb_ymin.bin',len_trim(trim(prname)//'absorb_ymin.bin'), &
+ reclen_ymin_crust_mantle*NSTEP)
+ endif
+ endif
+
+ if (nspec2D_ymax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ reclen_ymax_crust_mantle = CUSTOM_REAL * (NDIM * NGLLX * NGLLZ * nspec2D_ymax_crust_mantle)
+ if (SIMULATION_TYPE == 3) then
+! open(unit=54,file=trim(prname)//'absorb_ymax.bin', &
+! status='old',action='read',form='unformatted',access='direct',&
+! recl=reclen_ymax_crust_mantle+2*4)
+! else
+! open(unit=54,file=trim(prname)//'absorb_ymax.bin', &
+! status='unknown',form='unformatted',access='direct',&
+! recl=reclen_ymax_crust_mantle+2*4)
+
+ call open_file_abs_r(3,trim(prname)//'absorb_ymax.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
+ reclen_ymax_crust_mantle*NSTEP)
+ else
+ call open_file_abs_w(3,trim(prname)//'absorb_ymax.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
+ reclen_ymax_crust_mantle*NSTEP)
+ endif
+ endif
+
+
+ ! outer core
+ ! create name of database
+ call create_name_database(prname,myrank,IREGION_OUTER_CORE,LOCAL_PATH)
+
+ ! read arrays for Stacey conditions
+ open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin', &
+ status='old',form='unformatted',action='read')
+ read(27) nimin_outer_core
+ read(27) nimax_outer_core
+ read(27) njmin_outer_core
+ read(27) njmax_outer_core
+ read(27) nkmin_xi_outer_core
+ read(27) nkmin_eta_outer_core
+ close(27)
+
+ if (nspec2D_xmin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ reclen_xmin_outer_core = CUSTOM_REAL * (NGLLY * NGLLZ * nspec2D_xmin_outer_core)
+ if (SIMULATION_TYPE == 3) then
+! open(unit=61,file=trim(prname)//'absorb_xmin.bin', &
+! status='old',action='read',form='unformatted',access='direct', &
+! recl=reclen_xmin_outer_core+2*4)
+! else
+! open(unit=61,file=trim(prname)//'absorb_xmin.bin', &
+! status='unknown',form='unformatted',access='direct',&
+! recl=reclen_xmin_outer_core+2*4)
+
+ call open_file_abs_r(4,trim(prname)//'absorb_xmin.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
+ reclen_xmin_outer_core*NSTEP)
+ else
+ call open_file_abs_w(4,trim(prname)//'absorb_xmin.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
+ reclen_xmin_outer_core*NSTEP)
+ endif
+ endif
+
+ if (nspec2D_xmax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ reclen_xmax_outer_core = CUSTOM_REAL * (NGLLY * NGLLZ * nspec2D_xmax_outer_core)
+ if (SIMULATION_TYPE == 3) then
+! open(unit=62,file=trim(prname)//'absorb_xmax.bin', &
+! status='old',action='read',form='unformatted',access='direct', &
+! recl=reclen_xmax_outer_core+2*4)
+! else
+! open(unit=62,file=trim(prname)//'absorb_xmax.bin', &
+! status='unknown',form='unformatted',access='direct', &
+! recl=reclen_xmax_outer_core+2*4)
+
+ call open_file_abs_r(5,trim(prname)//'absorb_xmax.bin',len_trim(trim(prname)//'absorb_xmax.bin'), &
+ reclen_xmax_outer_core*NSTEP)
+ else
+ call open_file_abs_w(5,trim(prname)//'absorb_xmax.bin',len_trim(trim(prname)//'absorb_xmax.bin'), &
+ reclen_xmax_outer_core*NSTEP)
+ endif
+
+ endif
+
+ if (nspec2D_ymin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ reclen_ymin_outer_core = CUSTOM_REAL * (NGLLX * NGLLZ * nspec2D_ymin_outer_core)
+ if (SIMULATION_TYPE == 3) then
+! open(unit=63,file=trim(prname)//'absorb_ymin.bin', &
+! status='old',action='read',form='unformatted',access='direct',&
+! recl=reclen_ymin_outer_core+2*4)
+! else
+! open(unit=63,file=trim(prname)//'absorb_ymin.bin', &
+! status='unknown',form='unformatted',access='direct',&
+! recl=reclen_ymin_outer_core+2*4)
+
+ call open_file_abs_r(6,trim(prname)//'absorb_ymin.bin',len_trim(trim(prname)//'absorb_ymin.bin'), &
+ reclen_ymin_outer_core*NSTEP)
+ else
+ call open_file_abs_w(6,trim(prname)//'absorb_ymin.bin',len_trim(trim(prname)//'absorb_ymin.bin'), &
+ reclen_ymin_outer_core*NSTEP)
+
+ endif
+ endif
+
+ if (nspec2D_ymax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ reclen_ymax_outer_core = CUSTOM_REAL * (NGLLX * NGLLZ * nspec2D_ymax_outer_core)
+ if (SIMULATION_TYPE == 3) then
+! open(unit=64,file=trim(prname)//'absorb_ymax.bin', &
+! status='old',action='read',form='unformatted',access='direct',&
+! recl=reclen_ymax_outer_core+2*4)
+! else
+! open(unit=64,file=trim(prname)//'absorb_ymax.bin', &
+! status='unknown',form='unformatted',access='direct',&
+! recl=reclen_ymax_outer_core+2*4)
+
+ call open_file_abs_r(7,trim(prname)//'absorb_ymax.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
+ reclen_ymax_outer_core*NSTEP)
+ else
+ call open_file_abs_w(7,trim(prname)//'absorb_ymax.bin',len_trim(trim(prname)//'absorb_ymax.bin'), &
+ reclen_ymax_outer_core*NSTEP)
+
+ endif
+ endif
+
+ if (NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 .and. &
+ (SIMULATION_TYPE == 3 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD)))then
+ reclen_zmin = CUSTOM_REAL * (NGLLX * NGLLY * NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
+ if (SIMULATION_TYPE == 3) then
+! open(unit=65,file=trim(prname)//'absorb_zmin.bin', &
+! status='old',action='read',form='unformatted',access='direct',&
+! recl=reclen_zmin+2*4)
+! else
+! open(unit=65,file=trim(prname)//'absorb_zmin.bin', &
+! status='unknown',form='unformatted',access='direct',&
+! recl=reclen_zmin+2*4)
+
+ call open_file_abs_r(8,trim(prname)//'absorb_zmin.bin',len_trim(trim(prname)//'absorb_zmin.bin'), &
+ reclen_zmin*NSTEP)
+ else
+ call open_file_abs_w(8,trim(prname)//'absorb_zmin.bin',len_trim(trim(prname)//'absorb_zmin.bin'), &
+ reclen_zmin*NSTEP)
+ endif
+ endif
+
+ end subroutine read_mesh_databases_stacey
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_parameter_file.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/read_parameter_file.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_parameter_file.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_parameter_file.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,194 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine read_parameter_file(OUTPUT_FILES,LOCAL_PATH,MODEL, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, &
+ NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
+ CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
+ HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM,RECORD_LENGTH_IN_MINUTES, &
+ MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,MOVIE_SOUTH_DEG,&
+ ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
+ MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION,ABSORBING_CONDITIONS,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,NOISE_TOMOGRAPHY)
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read,NOISE_TOMOGRAPHY
+
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
+ CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
+ HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM, &
+ MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,&
+ MOVIE_SOUTH_DEG,RECORD_LENGTH_IN_MINUTES
+
+ logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,&
+ MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+
+! local variables
+ integer, external :: err_occurred
+
+ ! gets the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ ! opens the parameter file: DATA/Par_file
+ call open_parameter_file()
+
+ ! reads in values
+ call read_value_integer(SIMULATION_TYPE, 'solver.SIMULATION_TYPE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: SIMULATION_TYPE'
+ call read_value_integer(NOISE_TOMOGRAPHY, 'solver.NOISE_TOMOGRAPHY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NOISE_TOMOGRAPHY'
+ call read_value_logical(SAVE_FORWARD, 'solver.SAVE_FORWARD')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: SAVE_FORWARD'
+ call read_value_integer(NCHUNKS, 'mesher.NCHUNKS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NCHUNKS'
+ 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: ANGULAR_WIDTH_XI...'
+ 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: ANGULAR_WIDTH_ETA...'
+ 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: CENTER_LATITUDE...'
+ 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: CENTER_LONGITUDE...'
+ 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: GAMMA_ROTATION...'
+ ! 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: NEX_XI'
+ call read_value_integer(NEX_ETA_read, 'mesher.NEX_ETA')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NEX_ETA'
+ call read_value_integer(NPROC_XI_read, 'mesher.NPROC_XI')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NPROC_XI'
+ call read_value_integer(NPROC_ETA_read, 'mesher.NPROC_ETA')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NPROC_ETA'
+ call read_value_logical(OCEANS, 'model.OCEANS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: OCEANS'
+ call read_value_logical(ELLIPTICITY, 'model.ELLIPTICITY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: ELLIPTICITIY'
+ call read_value_logical(TOPOGRAPHY, 'model.TOPOGRAPHY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: TOPOGRAPHY'
+ call read_value_logical(GRAVITY, 'model.GRAVITY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: GRAVITY'
+ call read_value_logical(ROTATION, 'model.ROTATION')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: ROTATION'
+ call read_value_logical(ATTENUATION, 'model.ATTENUATION')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: ATTENUATION'
+ call read_value_logical(ABSORBING_CONDITIONS, 'solver.ABSORBING_CONDITIONS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: ABSORBING_CONDITIONS'
+ ! define the velocity model
+ call read_value_string(MODEL, 'model.MODEL')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MODEL'
+ call read_value_double_precision(RECORD_LENGTH_IN_MINUTES, 'solver.RECORD_LENGTH_IN_MINUTES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: RECORD_LENGTH..'
+ call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_SURFACE'
+ call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_VOLUME'
+ call read_value_logical(MOVIE_COARSE,'solver.MOVIE_COARSE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_COARSE'
+ call read_value_integer(NTSTEP_BETWEEN_FRAMES, 'solver.NTSTEP_BETWEEN_FRAMES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NTSTEP_BETWEEN_FRAMES'
+ call read_value_double_precision(HDUR_MOVIE, 'solver.HDUR_MOVIE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: HDUR_MOVIE'
+ call read_value_integer(MOVIE_VOLUME_TYPE, 'solver.MOVIE_VOLUME_TYPE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_VOLUME_TYPE'
+ 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: MOVIE_TOP_KM'
+ 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: MOVIE_BOTTOM_KM'
+ 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: MOVIE_WEST_DEG'
+ 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: MOVIE_EAST_DEG'
+ 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: MOVIE_NORTH_DEG'
+ 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: MOVIE_SOUTH_DEG'
+ call read_value_integer(MOVIE_START, 'solver.MOVIE_START')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_START'
+ call read_value_integer(MOVIE_STOP, 'solver.MOVIE_STOP')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: MOVIE_STOP'
+ call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: SAVE_MESH_FILES'
+ call read_value_integer(NUMBER_OF_RUNS, 'solver.NUMBER_OF_RUNS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: NUMBER_OF_RUNS'
+ 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: NUMBER_OF_THIS_RUN'
+ call read_value_string(LOCAL_PATH, 'LOCAL_PATH')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: LOCAL_PATH'
+ 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: NTSTEP_BETWEEN_OUTPUT_INFO'
+ 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: NTSTEP_BETWEEN_OUTPUT_SEISMOS'
+ 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: OUTPUT_SIESMOS_ASCII_TEXT'
+ 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: OUTPUT_SEISMOS_SAC_ALPHANUM'
+ 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: OUTPUT_SEISMOS_SAC_BINARY'
+ call read_value_logical(ROTATE_SEISMOGRAMS_RT, 'solver.ROTATE_SEISMOGRAMS_RT')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file: ROTATE_SEISMOGRAMS_RT'
+ 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: WRITE_SEISMOGRAMS_BY_MASTER'
+ 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: SAVE_ALL_SEISMOS_IN_ONE_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: USE_BINARY_FOR_LARGE_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: RECEIVERS_CAN_BE_BURIED'
+ 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: PRINT_SOURCE_TIME_FUNCTION'
+
+ ! closes parameter file
+ call close_parameter_file()
+
+ end subroutine read_parameter_file
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_value_parameters.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/read_value_parameters.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_value_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/read_value_parameters.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,180 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! 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
+ integer ierr
+ common /param_err_common/ ierr
+
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
+ 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
+ integer ierr
+ common /param_err_common/ ierr
+
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
+ 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
+ integer ierr
+ common /param_err_common/ ierr
+
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
+ 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=150) string_read
+ integer ierr
+ common /param_err_common/ ierr
+
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
+ value_to_read = string_read
+
+ end subroutine read_value_string
+
+!--------------------
+
+ subroutine open_parameter_file
+
+ integer ierr
+ common /param_err_common/ ierr
+ character(len=50) filename
+ filename = 'DATA/Par_file'
+
+ call param_open(filename, len(filename), ierr);
+ if (ierr .ne. 0) return
+
+ end subroutine open_parameter_file
+
+!--------------------
+
+ subroutine close_parameter_file
+
+ call param_close();
+
+ end subroutine close_parameter_file
+
+!--------------------
+
+ integer function err_occurred()
+
+ integer ierr
+ common /param_err_common/ ierr
+
+ err_occurred = ierr
+
+ end function err_occurred
+
+!--------------------
+
+!
+! unused routines:
+!
+
+! 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
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/recompute_jacobian.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/recompute_jacobian.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/recompute_jacobian.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/recompute_jacobian.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! 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/src/reduce.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/reduce.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/reduce.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/reduce.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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/src/rthetaphi_xyz.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/rthetaphi_xyz.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/rthetaphi_xyz.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/rthetaphi_xyz.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,122 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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*xmesh + ymesh*ymesh + zmesh*zmesh))
+
+ 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*xmesh + ymesh*ymesh + zmesh*zmesh)
+
+ 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*xmesh + ymesh*ymesh + zmesh*zmesh)
+
+ 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/src/save_arrays_solver.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/save_arrays_solver.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_arrays_solver.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_arrays_solver.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,440 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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,dvpstore, &
+ 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,is_on_a_slice_edge,rmass,rmass_ocean_load,npointot_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,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,OCEANS, &
+ tau_s,tau_e_store,Qmu_store,T_c_source,ATTENUATION,vx,vy,vz,vnspec, &
+ ABSORBING_CONDITIONS,SAVE_MESH_FILES)
+
+
+ implicit none
+
+ include "constants.h"
+
+! model_attenuation_variables
+! type model_attenuation_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
+! 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, dimension(:), pointer :: interval_Q ! Steps
+! integer :: Qn ! Number of points
+! integer dummy_pad ! padding 4 bytes to align the structure
+! end type model_attenuation_variables
+
+ logical ATTENUATION
+
+ character(len=150) prname
+ integer iregion_code
+
+ integer nspec,nglob,nspec_stacey
+ integer npointot_oceans
+
+! Stacey
+ real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey)
+ real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
+
+ logical TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS
+
+! arrays with jacobian matrix
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+! arrays with mesh parameters
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! for anisotropy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
+
+ integer nspec_ani
+ 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
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+! doubling mesh flag
+ integer, dimension(nspec) :: idoubling
+
+! this for non blocking MPI
+ logical, dimension(nspec) :: is_on_a_slice_edge
+
+! mass matrix
+ real(kind=CUSTOM_REAL) rmass(nglob)
+
+! additional ocean load mass matrix
+ real(kind=CUSTOM_REAL) rmass_ocean_load(npointot_oceans)
+
+! boundary parameters locator
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
+
+ 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)
+
+! normals
+ 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)
+
+! jacobian on 2D edges
+ 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)
+
+! number of elements on the boundaries
+ integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
+
+! attenuation
+ integer vx, vy, vz, vnspec
+ double precision T_c_source
+ double precision, dimension(N_SLS) :: tau_s
+ double precision, dimension(vx, vy, vz, vnspec) :: Qmu_store
+ double precision, dimension(N_SLS, vx, vy, vz, vnspec) :: tau_e_store
+
+ logical ABSORBING_CONDITIONS,SAVE_MESH_FILES
+
+ ! local parameters
+ integer i,j,k,ispec,iglob,nspec1, nglob1
+ real(kind=CUSTOM_REAL) scaleval1,scaleval2
+
+! save nspec and nglob, to be used in combine_paraview_data
+ open(unit=27,file=prname(1:len_trim(prname))//'array_dims.txt',status='unknown',action='write')
+
+ nspec1 = nspec
+ nglob1 = nglob
+
+ ! might be wrong, check...
+ !if (NCHUNKS == 6 .and. ichunk /= CHUNK_AB .and. iregion_code == IREGION_INNER_CORE) then
+ ! ! only chunk_AB contains inner core?
+ ! ratio_divide_central_cube = 16
+ ! ! corrects nspec/nglob
+ ! nspec1 = nspec1 - (NEX_PER_PROC_XI/ratio_divide_central_cube) &
+ ! * (NEX_PER_PROC_ETA/ratio_divide_central_cube) * (NEX_XI/ratio_divide_central_cube)
+ ! nglob1 = nglob1 - ((NEX_PER_PROC_XI/ratio_divide_central_cube)*(NGLLX-1)+1) &
+ ! * ((NEX_PER_PROC_ETA/ratio_divide_central_cube)*(NGLLY-1)+1) &
+ ! * (NEX_XI/ratio_divide_central_cube)*(NGLLZ-1)
+ !endif
+
+ write(27,*) nspec1
+ write(27,*) nglob1
+ close(27)
+
+ open(unit=27,file=prname(1:len_trim(prname))//'solver_data_1.bin',status='unknown',form='unformatted',action='write')
+
+ write(27) xixstore
+ write(27) xiystore
+ write(27) xizstore
+ write(27) etaxstore
+ write(27) etaystore
+ write(27) etazstore
+ write(27) gammaxstore
+ write(27) gammaystore
+ write(27) gammazstore
+
+ write(27) rhostore
+ write(27) kappavstore
+
+ if(HETEROGEN_3D_MANTLE) then
+ open(unit=29,file=prname(1:len_trim(prname))//'dvp.bin',status='unknown',form='unformatted',action='write')
+ write(29) dvpstore
+ close(29)
+ endif
+
+! other terms needed in the solid regions only
+ if(iregion_code /= IREGION_OUTER_CORE) then
+
+ if(.not. (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) write(27) muvstore
+
+! save anisotropy in the mantle only
+ if(TRANSVERSE_ISOTROPY) then
+ if(iregion_code == IREGION_CRUST_MANTLE .and. .not. ANISOTROPIC_3D_MANTLE) then
+ write(27) kappahstore
+ write(27) muhstore
+ write(27) eta_anisostore
+ endif
+ endif
+
+! save anisotropy in the inner core only
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
+ write(27) c11store
+ write(27) c33store
+ write(27) c12store
+ write(27) c13store
+ write(27) c44store
+ endif
+
+
+
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ write(27) c11store
+ write(27) c12store
+ write(27) c13store
+ write(27) c14store
+ write(27) c15store
+ write(27) c16store
+ write(27) c22store
+ write(27) c23store
+ write(27) c24store
+ write(27) c25store
+ write(27) c26store
+ write(27) c33store
+ write(27) c34store
+ write(27) c35store
+ write(27) c36store
+ write(27) c44store
+ write(27) c45store
+ write(27) c46store
+ write(27) c55store
+ write(27) c56store
+ write(27) c66store
+ endif
+
+ endif
+
+! Stacey
+ if(ABSORBING_CONDITIONS) then
+
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ write(27) rho_vp
+ write(27) rho_vs
+ else if(iregion_code == IREGION_OUTER_CORE) then
+ write(27) rho_vp
+ endif
+
+ endif
+
+! mass matrix
+ write(27) rmass
+
+! additional ocean load mass matrix if oceans and if we are in the crust
+ if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) write(27) rmass_ocean_load
+
+ close(27)
+
+ open(unit=27,file=prname(1:len_trim(prname))//'solver_data_2.bin',status='unknown',form='unformatted',action='write')
+! mesh arrays used in the solver to locate source and receivers
+! and for anisotropy and gravity, save in single precision
+! use rmass for temporary storage to perform conversion, since already saved
+
+!--- x coordinate
+ rmass(:) = 0._CUSTOM_REAL
+ do ispec = 1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = sngl(xstore(i,j,k,ispec))
+ else
+ rmass(iglob) = xstore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ write(27) rmass
+
+!--- y coordinate
+ rmass(:) = 0._CUSTOM_REAL
+ do ispec = 1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = sngl(ystore(i,j,k,ispec))
+ else
+ rmass(iglob) = ystore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ write(27) rmass
+
+!--- z coordinate
+ rmass(:) = 0._CUSTOM_REAL
+ do ispec = 1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = sngl(zstore(i,j,k,ispec))
+ else
+ rmass(iglob) = zstore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ write(27) rmass
+
+ write(27) ibool
+
+ write(27) idoubling
+
+ write(27) is_on_a_slice_edge
+
+ close(27)
+
+! absorbing boundary parameters
+ open(unit=27,file=prname(1:len_trim(prname))//'boundary.bin',status='unknown',form='unformatted',action='write')
+
+ write(27) nspec2D_xmin
+ write(27) nspec2D_xmax
+ write(27) nspec2D_ymin
+ write(27) nspec2D_ymax
+ write(27) NSPEC2D_BOTTOM
+ write(27) NSPEC2D_TOP
+
+ write(27) ibelm_xmin
+ write(27) ibelm_xmax
+ write(27) ibelm_ymin
+ write(27) ibelm_ymax
+ write(27) ibelm_bottom
+ write(27) ibelm_top
+
+ write(27) normal_xmin
+ write(27) normal_xmax
+ write(27) normal_ymin
+ write(27) normal_ymax
+ write(27) normal_bottom
+ write(27) normal_top
+
+ write(27) jacobian2D_xmin
+ write(27) jacobian2D_xmax
+ write(27) jacobian2D_ymin
+ write(27) jacobian2D_ymax
+ write(27) jacobian2D_bottom
+ write(27) jacobian2D_top
+
+ close(27)
+
+!> Hejun
+! No matter 1D or 3D Attenuation, we save value for gll points
+ if(ATTENUATION) then
+ open(unit=27, file=prname(1:len_trim(prname))//'attenuation.bin', status='unknown', form='unformatted',action='write')
+ write(27) tau_s
+ write(27) tau_e_store
+ write(27) Qmu_store
+ write(27) T_c_source
+ close(27)
+ endif
+
+ ! uncomment for vp & vs model storage
+ if( SAVE_MESH_FILES ) then
+ scaleval1 = sngl( sqrt(PI*GRAV*RHOAV)*(R_EARTH/1000.0d0) )
+ scaleval2 = sngl( RHOAV/1000.0d0 )
+
+ ! isotropic model
+ ! vp
+ open(unit=27,file=prname(1:len_trim(prname))//'vp.bin',status='unknown',form='unformatted',action='write')
+ write(27) sqrt( (kappavstore+4.*muvstore/3.)/rhostore )*scaleval1
+ close(27)
+ ! vs
+ open(unit=27,file=prname(1:len_trim(prname))//'vs.bin',status='unknown',form='unformatted',action='write')
+ write(27) sqrt( muvstore/rhostore )*scaleval1
+ close(27)
+ ! rho
+ open(unit=27,file=prname(1:len_trim(prname))//'rho.bin',status='unknown',form='unformatted',action='write')
+ write(27) rhostore*scaleval2
+ close(27)
+
+ ! transverse isotropic model
+ if( TRANSVERSE_ISOTROPY ) then
+ ! vpv
+ open(unit=27,file=prname(1:len_trim(prname))//'vpv.bin',status='unknown',form='unformatted',action='write')
+ write(27) sqrt( (kappavstore+4.*muvstore/3.)/rhostore )*scaleval1
+ close(27)
+ ! vph
+ open(unit=27,file=prname(1:len_trim(prname))//'vph.bin',status='unknown',form='unformatted',action='write')
+ write(27) sqrt( (kappahstore+4.*muhstore/3.)/rhostore )*scaleval1
+ close(27)
+ ! vsv
+ open(unit=27,file=prname(1:len_trim(prname))//'vsv.bin',status='unknown',form='unformatted',action='write')
+ write(27) sqrt( muvstore/rhostore )*scaleval1
+ close(27)
+ ! vsh
+ open(unit=27,file=prname(1:len_trim(prname))//'vsh.bin',status='unknown',form='unformatted',action='write')
+ write(27) sqrt( muhstore/rhostore )*scaleval1
+ close(27)
+ ! rho
+ open(unit=27,file=prname(1:len_trim(prname))//'rho.bin',status='unknown',form='unformatted',action='write')
+ write(27) rhostore*scaleval2
+ close(27)
+ ! eta
+ open(unit=27,file=prname(1:len_trim(prname))//'eta.bin',status='unknown',form='unformatted',action='write')
+ write(27) eta_anisostore
+ close(27)
+ endif
+
+ endif
+
+ end subroutine save_arrays_solver
+
+
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_forward_arrays.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/save_forward_arrays.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_forward_arrays.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_forward_arrays.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,122 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine save_forward_arrays(myrank,SIMULATION_TYPE,SAVE_FORWARD, &
+ NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
+ displ_inner_core,veloc_inner_core,accel_inner_core, &
+ displ_outer_core,veloc_outer_core,accel_outer_core, &
+ R_memory_crust_mantle,R_memory_inner_core, &
+ epsilondev_crust_mantle,epsilondev_inner_core, &
+ A_array_rotation,B_array_rotation, &
+ LOCAL_PATH)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ integer SIMULATION_TYPE
+ logical SAVE_FORWARD
+ integer NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
+ displ_inner_core,veloc_inner_core,accel_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
+ displ_outer_core,veloc_outer_core,accel_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: &
+ R_memory_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
+ epsilondev_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
+ R_memory_inner_core
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: &
+ epsilondev_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
+ A_array_rotation,B_array_rotation
+
+ character(len=150) LOCAL_PATH
+
+ ! local parameters
+ character(len=150) outputname
+
+
+ ! save files to local disk or tape system if restart file
+ if(NUMBER_OF_RUNS > 1 .and. NUMBER_OF_THIS_RUN < NUMBER_OF_RUNS) then
+ write(outputname,"('dump_all_arrays',i6.6)") myrank
+ open(unit=55,file=trim(LOCAL_PATH)//'/'//outputname,status='unknown',form='unformatted',action='write')
+ write(55) displ_crust_mantle
+ write(55) veloc_crust_mantle
+ write(55) accel_crust_mantle
+ write(55) displ_inner_core
+ write(55) veloc_inner_core
+ write(55) accel_inner_core
+ write(55) displ_outer_core
+ write(55) veloc_outer_core
+ write(55) accel_outer_core
+ write(55) epsilondev_crust_mantle
+ write(55) epsilondev_inner_core
+ write(55) A_array_rotation
+ write(55) B_array_rotation
+ write(55) R_memory_crust_mantle
+ write(55) R_memory_inner_core
+ close(55)
+ endif
+
+ ! save last frame of the forward simulation
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ write(outputname,'(a,i6.6,a)') 'proc',myrank,'_save_forward_arrays.bin'
+ open(unit=55,file=trim(LOCAL_PATH)//'/'//outputname,status='unknown',form='unformatted',action='write')
+ write(55) displ_crust_mantle
+ write(55) veloc_crust_mantle
+ write(55) accel_crust_mantle
+ write(55) displ_inner_core
+ write(55) veloc_inner_core
+ write(55) accel_inner_core
+ write(55) displ_outer_core
+ write(55) veloc_outer_core
+ write(55) accel_outer_core
+ write(55) epsilondev_crust_mantle
+ write(55) epsilondev_inner_core
+ if (ROTATION_VAL) then
+ write(55) A_array_rotation
+ write(55) B_array_rotation
+ endif
+ if (ATTENUATION_VAL) then
+ write(55) R_memory_crust_mantle
+ write(55) R_memory_inner_core
+ endif
+ close(55)
+ endif
+
+ end subroutine save_forward_arrays
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_header_file.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/save_header_file.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_header_file.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_header_file.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,529 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! 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,OCEANS,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, &
+ SIMULATION_TYPE,SAVE_FORWARD,MOVIE_VOLUME)
+
+ 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,OCEANS,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
+
+ integer :: SIMULATION_TYPE
+ logical :: SAVE_FORWARD,MOVIE_VOLUME
+
+
+! 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% or 90%'
+ write(IOUT,*) '! of the memory installed per core)'
+ 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(OCEANS) then
+ write(IOUT,*) 'logical, parameter :: OCEANS_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: OCEANS_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 = ', &
+ max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE))
+
+ 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
+ stop 'error nchunks in save_header_file()'
+ 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
+ att1 = NGLLX
+ att2 = NGLLY
+ att3 = NGLLZ
+ att4 = NSPEC(IREGION_CRUST_MANTLE)
+ att5 = NSPEC(IREGION_INNER_CORE)
+ 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
+
+ ! deville routines only implemented for NGLLX = NGLLY = NGLLZ = 5
+ if( NGLLX == 5 .and. NGLLY == 5 .and. NGLLZ == 5 ) then
+ write(IOUT,*) 'logical, parameter :: USE_DEVILLE_PRODUCTS_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: USE_DEVILLE_PRODUCTS_VAL = .false.'
+ endif
+
+ ! backward/reconstruction of forward wavefield:
+ ! can only mimic attenuation effects on velocity at this point, since no full wavefield snapshots are stored
+ if((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then
+
+ ! attenuation mimic:
+ ! mimicking effect of attenuation on apparent velocities, not amplitudes. that is,
+ ! phase shifts should be correctly accounted for, but amplitudes will differ in adjoint simulations
+ if( ATTENUATION ) then
+ write(IOUT,*) 'logical, parameter :: USE_ATTENUATION_MIMIC = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: USE_ATTENUATION_MIMIC = .false.'
+ endif
+
+ else
+
+ ! calculates full attenuation (phase & amplitude effects) if used
+ write(IOUT,*) 'logical, parameter :: USE_ATTENUATION_MIMIC = .false.'
+ endif
+
+ ! attenuation and/or adjoint simulations
+ if (ATTENUATION .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD &
+ .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
+ write(IOUT,*) 'logical, parameter :: COMPUTE_AND_STORE_STRAIN = .true. '
+ else
+ write(IOUT,*) 'logical, parameter :: COMPUTE_AND_STORE_STRAIN = .false.'
+ endif
+
+
+
+ close(IOUT)
+
+ end subroutine save_header_file
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_kernels.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/save_kernels.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_kernels.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/save_kernels.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,801 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine save_kernels_crust_mantle(myrank,scale_t,scale_displ, &
+ cijkl_kl_crust_mantle,rho_kl_crust_mantle, &
+ alpha_kl_crust_mantle,beta_kl_crust_mantle, &
+ ystore_crust_mantle,zstore_crust_mantle, &
+ rhostore_crust_mantle,muvstore_crust_mantle, &
+ kappavstore_crust_mantle,ibool_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle, &
+ eta_anisostore_crust_mantle,idoubling_crust_mantle, &
+ LOCAL_PATH)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ double precision :: scale_t,scale_displ
+
+ real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ cijkl_kl_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ rho_kl_crust_mantle, beta_kl_crust_mantle, alpha_kl_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
+ ystore_crust_mantle,zstore_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
+ rhostore_crust_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
+
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ character(len=150) LOCAL_PATH
+
+ ! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ mu_kl_crust_mantle, kappa_kl_crust_mantle, rhonotprime_kl_crust_mantle
+ real(kind=CUSTOM_REAL),dimension(21) :: cijkl_kl_local
+ real(kind=CUSTOM_REAL) :: scale_kl,scale_kl_ani,scale_kl_rho
+ real(kind=CUSTOM_REAL) :: rhol,mul,kappal,rho_kl,alpha_kl,beta_kl
+ integer :: ispec,i,j,k,iglob
+ character(len=150) prname
+
+ ! transverse isotropic parameters
+ real(kind=CUSTOM_REAL), dimension(21) :: an_kl
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: &
+ alphav_kl_crust_mantle,alphah_kl_crust_mantle, &
+ betav_kl_crust_mantle,betah_kl_crust_mantle, &
+ eta_kl_crust_mantle
+
+ ! bulk parameterization
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: &
+ bulk_c_kl_crust_mantle,bulk_beta_kl_crust_mantle, &
+ bulk_betav_kl_crust_mantle,bulk_betah_kl_crust_mantle
+ real(kind=CUSTOM_REAL) :: A,C,F,L,N,eta
+ real(kind=CUSTOM_REAL) :: muvl,kappavl,muhl,kappahl
+ real(kind=CUSTOM_REAL) :: alphav_sq,alphah_sq,betav_sq,betah_sq,bulk_sq
+
+ ! scaling factors
+ scale_kl = scale_t/scale_displ * 1.d9
+ ! For anisotropic kernels
+ ! final unit : [s km^(-3) GPa^(-1)]
+ scale_kl_ani = scale_t**3 / (RHOAV*R_EARTH**3) * 1.d18
+ ! final unit : [s km^(-3) (kg/m^3)^(-1)]
+ scale_kl_rho = scale_t / scale_displ / RHOAV * 1.d9
+
+ ! allocates temporary arrays
+ if( SAVE_TRANSVERSE_KL ) then
+ ! transverse isotropic kernel arrays for file output
+ allocate(alphav_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ alphah_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ betav_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ betah_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ eta_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT))
+
+ ! isotropic kernel arrays for file output
+ allocate(bulk_c_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ bulk_betav_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ bulk_betah_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ bulk_beta_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT))
+ endif
+
+ if( .not. ANISOTROPIC_KL ) then
+ ! allocates temporary isotropic kernel arrays for file output
+ allocate(bulk_c_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ bulk_beta_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT))
+ endif
+
+ ! crust_mantle
+ do ispec = 1, NSPEC_CRUST_MANTLE
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+
+ if (ANISOTROPIC_KL) then
+
+ ! For anisotropic kernels
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+
+ ! The cartesian global cijkl_kl are rotated into the spherical local cijkl_kl
+ ! ystore and zstore are thetaval and phival (line 2252) -- dangerous
+ call rotate_kernels_dble(cijkl_kl_crust_mantle(:,i,j,k,ispec),cijkl_kl_local, &
+ ystore_crust_mantle(iglob),zstore_crust_mantle(iglob))
+
+ cijkl_kl_crust_mantle(:,i,j,k,ispec) = cijkl_kl_local * scale_kl_ani
+ rho_kl_crust_mantle(i,j,k,ispec) = rho_kl_crust_mantle(i,j,k,ispec) * scale_kl_rho
+
+ ! transverse isotropic kernel calculations
+ if( SAVE_TRANSVERSE_KL ) then
+ ! note: transverse isotropic kernels are calculated for all elements
+ !
+ ! however, the factors A,C,L,N,F are based only on transverse elements
+ ! in between Moho and 220 km layer, otherwise they are taken from isotropic values
+
+ rhol = rhostore_crust_mantle(i,j,k,ispec)
+
+ ! transverse isotropic parameters from compute_force_crust_mantle.f90
+ ! C=rhovpvsq A=rhovphsq L=rhovsvsq N=rhovshsq eta=F/(A - 2 L)
+
+ ! Get A,C,F,L,N,eta from kappa,mu
+ ! element can have transverse isotropy if between d220 and Moho
+ if( .not. (TRANSVERSE_ISOTROPY_VAL .and. &
+ (idoubling_crust_mantle(ispec) == IFLAG_80_MOHO .or. &
+ idoubling_crust_mantle(ispec) == IFLAG_220_80))) then
+
+ ! layer with no transverse isotropy
+ ! A,C,L,N,F from isotropic model
+
+ mul = muvstore_crust_mantle(i,j,k,ispec)
+ kappal = kappavstore_crust_mantle(i,j,k,ispec)
+ muvl = mul
+ muhl = mul
+ kappavl = kappal
+ kappahl = kappal
+
+ A = kappal + FOUR_THIRDS * mul
+ C = A
+ L = mul
+ N = mul
+ F = kappal - 2._CUSTOM_REAL/3._CUSTOM_REAL * mul
+ eta = 1._CUSTOM_REAL
+
+ else
+
+ ! A,C,L,N,F from transverse isotropic model
+ kappavl = kappavstore_crust_mantle(i,j,k,ispec)
+ kappahl = kappahstore_crust_mantle(i,j,k,ispec)
+ muvl = muvstore_crust_mantle(i,j,k,ispec)
+ muhl = muhstore_crust_mantle(i,j,k,ispec)
+ kappal = kappavl
+
+ A = kappahl + FOUR_THIRDS * muhl
+ C = kappavl + FOUR_THIRDS * muvl
+ L = muvl
+ N = muhl
+ eta = eta_anisostore_crust_mantle(i,j,k,ispec) ! that is F / (A - 2 L)
+ F = eta * ( A - 2._CUSTOM_REAL * L )
+
+ endif
+
+ ! note: cijkl_kl_local() is fully anisotropic C_ij kernel components (non-dimensionalized)
+ ! for GLL point at (i,j,k,ispec)
+
+ ! Purpose : compute the kernels for the An coeffs (an_kl)
+ ! from the kernels for Cij (cijkl_kl_local)
+ ! At r,theta,phi fixed
+ ! kernel def : dx = kij * dcij + krho * drho
+ ! = kAn * dAn + krho * drho
+
+ ! Definition of the input array cij_kl :
+ ! cij_kl(1) = C11 ; cij_kl(2) = C12 ; cij_kl(3) = C13
+ ! cij_kl(4) = C14 ; cij_kl(5) = C15 ; cij_kl(6) = C16
+ ! cij_kl(7) = C22 ; cij_kl(8) = C23 ; cij_kl(9) = C24
+ ! cij_kl(10) = C25 ; cij_kl(11) = C26 ; cij_kl(12) = C33
+ ! cij_kl(13) = C34 ; cij_kl(14) = C35 ; cij_kl(15) = C36
+ ! cij_kl(16) = C44 ; cij_kl(17) = C45 ; cij_kl(18) = C46
+ ! cij_kl(19) = C55 ; cij_kl(20) = C56 ; cij_kl(21) = C66
+ ! where the Cij (Voigt's notation) are defined as function of
+ ! the components of the elastic tensor in spherical coordinates
+ ! by eq. (A.1) of Chen & Tromp, GJI 168 (2007)
+
+ ! From the relations giving Cij in function of An
+ ! Checked with Min Chen's results (routine build_cij)
+
+ an_kl(1) = cijkl_kl_local(1)+cijkl_kl_local(2)+cijkl_kl_local(7) !A
+ an_kl(2) = cijkl_kl_local(12) !C
+ an_kl(3) = -2*cijkl_kl_local(2)+cijkl_kl_local(21) !N
+ an_kl(4) = cijkl_kl_local(16)+cijkl_kl_local(19) !L
+ an_kl(5) = cijkl_kl_local(3)+cijkl_kl_local(8) !F
+
+ ! not used yet
+ !an_kl(6)=2*cijkl_kl_local(5)+2*cijkl_kl_local(10)+2*cijkl_kl_local(14) !Jc
+ !an_kl(7)=2*cijkl_kl_local(4)+2*cijkl_kl_local(9)+2*cijkl_kl_local(13) !Js
+ !an_kl(8)=-2*cijkl_kl_local(14) !Kc
+ !an_kl(9)=-2*cijkl_kl_local(13) !Ks
+ !an_kl(10)=-2*cijkl_kl_local(10)+cijkl_kl_local(18) !Mc
+ !an_kl(11)=2*cijkl_kl_local(4)-cijkl_kl_local(20) !Ms
+ !an_kl(12)=cijkl_kl_local(1)-cijkl_kl_local(7) !Bc
+ !an_kl(13)=-1./2.*(cijkl_kl_local(6)+cijkl_kl_local(11)) !Bs
+ !an_kl(14)=cijkl_kl_local(3)-cijkl_kl_local(8) !Hc
+ !an_kl(15)=-cijkl_kl_local(15) !Hs
+ !an_kl(16)=-cijkl_kl_local(16)+cijkl_kl_local(19) !Gc
+ !an_kl(17)=-cijkl_kl_local(17) !Gs
+ !an_kl(18)=cijkl_kl_local(5)-cijkl_kl_local(10)-cijkl_kl_local(18) !Dc
+ !an_kl(19)=cijkl_kl_local(4)-cijkl_kl_local(9)+cijkl_kl_local(20) !Ds
+ !an_kl(20)=cijkl_kl_local(1)-cijkl_kl_local(2)+cijkl_kl_local(7)-cijkl_kl_local(21) !Ec
+ !an_kl(21)=-cijkl_kl_local(6)+cijkl_kl_local(11) !Es
+
+ ! K_rho (primary kernel, for a parameterization (A,C,L,N,F,rho) )
+ rhonotprime_kl_crust_mantle(i,j,k,ispec) = rhol * rho_kl_crust_mantle(i,j,k,ispec) / scale_kl_rho
+
+ ! note: transverse isotropic kernels are calculated for ALL elements,
+ ! and not just transverse elements
+ !
+ ! note: the kernels are for relative perturbations (delta ln (m_i) = (m_i - m_0)/m_i )
+ !
+ ! Gets transverse isotropic kernels
+ ! (see Appendix B of Sieminski et al., GJI 171, 2007)
+
+ ! for parameterization: ( alpha_v, alpha_h, beta_v, beta_h, eta, rho )
+ ! K_alpha_v
+ alphav_kl_crust_mantle(i,j,k,ispec) = 2*C*an_kl(2)
+ ! K_alpha_h
+ alphah_kl_crust_mantle(i,j,k,ispec) = 2*A*an_kl(1) + 2*A*eta*an_kl(5)
+ ! K_beta_v
+ betav_kl_crust_mantle(i,j,k,ispec) = 2*L*an_kl(4) - 4*L*eta*an_kl(5)
+ ! K_beta_h
+ betah_kl_crust_mantle(i,j,k,ispec) = 2*N*an_kl(3)
+ ! K_eta
+ eta_kl_crust_mantle(i,j,k,ispec) = F*an_kl(5)
+ ! K_rhoprime (for a parameterization (alpha_v, ..., rho) )
+ rho_kl_crust_mantle(i,j,k,ispec) = A*an_kl(1) + C*an_kl(2) &
+ + N*an_kl(3) + L*an_kl(4) + F*an_kl(5) &
+ + rhonotprime_kl_crust_mantle(i,j,k,ispec)
+
+ ! write the kernel in physical units (01/05/2006)
+ rhonotprime_kl_crust_mantle(i,j,k,ispec) = - rhonotprime_kl_crust_mantle(i,j,k,ispec) * scale_kl
+
+ alphav_kl_crust_mantle(i,j,k,ispec) = - alphav_kl_crust_mantle(i,j,k,ispec) * scale_kl
+ alphah_kl_crust_mantle(i,j,k,ispec) = - alphah_kl_crust_mantle(i,j,k,ispec) * scale_kl
+ betav_kl_crust_mantle(i,j,k,ispec) = - betav_kl_crust_mantle(i,j,k,ispec) * scale_kl
+ betah_kl_crust_mantle(i,j,k,ispec) = - betah_kl_crust_mantle(i,j,k,ispec) * scale_kl
+ eta_kl_crust_mantle(i,j,k,ispec) = - eta_kl_crust_mantle(i,j,k,ispec) * scale_kl
+ rho_kl_crust_mantle(i,j,k,ispec) = - rho_kl_crust_mantle(i,j,k,ispec) * scale_kl
+
+ ! for parameterization: ( bulk, beta_v, beta_h, eta, rho )
+ ! where kappa_v = kappa_h = kappa and bulk c = sqrt( kappa / rho )
+ betav_sq = muvl / rhol
+ betah_sq = muhl / rhol
+ alphav_sq = ( kappal + FOUR_THIRDS * muvl ) / rhol
+ alphah_sq = ( kappal + FOUR_THIRDS * muhl ) / rhol
+ bulk_sq = kappal / rhol
+
+ bulk_c_kl_crust_mantle(i,j,k,ispec) = &
+ bulk_sq / alphav_sq * alphav_kl_crust_mantle(i,j,k,ispec) + &
+ bulk_sq / alphah_sq * alphah_kl_crust_mantle(i,j,k,ispec)
+
+ bulk_betah_kl_crust_mantle(i,j,k,ispec ) = &
+ betah_kl_crust_mantle(i,j,k,ispec) + &
+ FOUR_THIRDS * betah_sq / alphah_sq * alphah_kl_crust_mantle(i,j,k,ispec)
+
+ bulk_betav_kl_crust_mantle(i,j,k,ispec ) = &
+ betav_kl_crust_mantle(i,j,k,ispec) + &
+ FOUR_THIRDS * betav_sq / alphav_sq * alphav_kl_crust_mantle(i,j,k,ispec)
+ ! the rest, K_eta and K_rho are the same as above
+
+ ! to check: isotropic kernels from transverse isotropic ones
+ alpha_kl_crust_mantle(i,j,k,ispec) = alphav_kl_crust_mantle(i,j,k,ispec) &
+ + alphah_kl_crust_mantle(i,j,k,ispec)
+ beta_kl_crust_mantle(i,j,k,ispec) = betav_kl_crust_mantle(i,j,k,ispec) &
+ + betah_kl_crust_mantle(i,j,k,ispec)
+ !rho_kl_crust_mantle(i,j,k,ispec) = rhonotprime_kl_crust_mantle(i,j,k,ispec) &
+ ! + alpha_kl_crust_mantle(i,j,k,ispec) &
+ ! + beta_kl_crust_mantle(i,j,k,ispec)
+ bulk_beta_kl_crust_mantle(i,j,k,ispec) = bulk_betah_kl_crust_mantle(i,j,k,ispec ) &
+ + bulk_betav_kl_crust_mantle(i,j,k,ispec )
+
+ endif ! SAVE_TRANSVERSE_KL
+
+ else
+
+ ! isotropic kernels
+
+ rhol = rhostore_crust_mantle(i,j,k,ispec)
+ mul = muvstore_crust_mantle(i,j,k,ispec)
+ kappal = kappavstore_crust_mantle(i,j,k,ispec)
+
+ ! kernel values for rho, kappa, mu (primary kernel values)
+ rho_kl = - rhol * rho_kl_crust_mantle(i,j,k,ispec)
+ alpha_kl = - kappal * alpha_kl_crust_mantle(i,j,k,ispec) ! note: alpha_kl corresponds to K_kappa
+ beta_kl = - 2 * mul * beta_kl_crust_mantle(i,j,k,ispec) ! note: beta_kl corresponds to K_mu
+
+ ! for a parameterization: (rho,mu,kappa) "primary" kernels
+ rhonotprime_kl_crust_mantle(i,j,k,ispec) = rho_kl * scale_kl
+ mu_kl_crust_mantle(i,j,k,ispec) = beta_kl * scale_kl
+ kappa_kl_crust_mantle(i,j,k,ispec) = alpha_kl * scale_kl
+
+ ! for a parameterization: (rho,alpha,beta)
+ ! kernels rho^prime, beta, alpha
+ rho_kl_crust_mantle(i,j,k,ispec) = (rho_kl + alpha_kl + beta_kl) * scale_kl
+ beta_kl_crust_mantle(i,j,k,ispec) = &
+ 2._CUSTOM_REAL * (beta_kl - FOUR_THIRDS * mul * alpha_kl / kappal) * scale_kl
+ alpha_kl_crust_mantle(i,j,k,ispec) = &
+ 2._CUSTOM_REAL * (1 + FOUR_THIRDS * mul / kappal) * alpha_kl * scale_kl
+
+ ! for a parameterization: (rho,bulk, beta)
+ ! where bulk wave speed is c = sqrt( kappa / rho)
+ ! note: rhoprime is the same as for (rho,alpha,beta) parameterization
+ bulk_c_kl_crust_mantle(i,j,k,ispec) = 2._CUSTOM_REAL * alpha_kl * scale_kl
+ bulk_beta_kl_crust_mantle(i,j,k,ispec ) = 2._CUSTOM_REAL * beta_kl * scale_kl
+
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
+
+ ! For anisotropic kernels
+ if (ANISOTROPIC_KL) then
+
+ ! outputs transverse isotropic kernels only
+ if( SAVE_TRANSVERSE_KL ) then
+ ! transverse isotropic kernels
+ ! (alpha_v, alpha_h, beta_v, beta_h, eta, rho ) parameterization
+ open(unit=27,file=trim(prname)//'alphav_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) alphav_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'alphah_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) alphah_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'betav_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) betav_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'betah_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) betah_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'eta_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) eta_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) rho_kl_crust_mantle
+ close(27)
+
+ ! in case one is interested in primary kernel K_rho
+ !open(unit=27,file=trim(prname)//'rhonotprime_kernel.bin',status='unknown',form='unformatted',action='write')
+ !write(27) rhonotprime_kl_crust_mantle
+ !close(27)
+
+ ! (bulk, beta_v, beta_h, eta, rho ) parameterization: K_eta and K_rho same as above
+ open(unit=27,file=trim(prname)//'bulk_c_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) bulk_c_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'bulk_betav_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) bulk_betav_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'bulk_betah_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) bulk_betah_kl_crust_mantle
+ close(27)
+
+ ! to check: isotropic kernels
+ open(unit=27,file=trim(prname)//'alpha_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) alpha_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'beta_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) beta_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'bulk_beta_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) bulk_beta_kl_crust_mantle
+ close(27)
+
+ else
+
+ ! fully anisotropic kernels
+ ! note: the C_ij and density kernels are not for relative perturbations (delta ln( m_i) = delta m_i / m_i),
+ ! but absolute perturbations (delta m_i = m_i - m_0)
+ open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) - rho_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'cijkl_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) - cijkl_kl_crust_mantle
+ close(27)
+
+ endif
+
+ else
+ ! primary kernels: (rho,kappa,mu) parameterization
+ open(unit=27,file=trim(prname)//'rhonotprime_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) rhonotprime_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'kappa_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) kappa_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'mu_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) mu_kl_crust_mantle
+ close(27)
+
+ ! (rho, alpha, beta ) parameterization
+ open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) rho_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'alpha_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) alpha_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'beta_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) beta_kl_crust_mantle
+ close(27)
+
+ ! (rho, bulk, beta ) parameterization, K_rho same as above
+ open(unit=27,file=trim(prname)//'bulk_c_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) bulk_c_kl_crust_mantle
+ close(27)
+ open(unit=27,file=trim(prname)//'bulk_beta_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) bulk_beta_kl_crust_mantle
+ close(27)
+
+
+ endif
+
+ ! cleans up temporary kernel arrays
+ if( SAVE_TRANSVERSE_KL ) then
+ deallocate(alphav_kl_crust_mantle,alphah_kl_crust_mantle, &
+ betav_kl_crust_mantle,betah_kl_crust_mantle, &
+ eta_kl_crust_mantle)
+ deallocate(bulk_c_kl_crust_mantle,bulk_betah_kl_crust_mantle, &
+ bulk_betav_kl_crust_mantle,bulk_beta_kl_crust_mantle)
+ endif
+ if( .not. ANISOTROPIC_KL ) then
+ deallocate(bulk_c_kl_crust_mantle,bulk_beta_kl_crust_mantle)
+ endif
+
+ end subroutine save_kernels_crust_mantle
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine save_kernels_outer_core(myrank,scale_t,scale_displ, &
+ rho_kl_outer_core,alpha_kl_outer_core, &
+ rhostore_outer_core,kappavstore_outer_core, &
+ deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
+ LOCAL_PATH)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ double precision :: scale_t,scale_displ
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: &
+ rho_kl_outer_core,alpha_kl_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
+ rhostore_outer_core,kappavstore_outer_core
+
+ integer nspec_beta_kl_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_beta_kl_outer_core) :: &
+ beta_kl_outer_core
+ logical deviatoric_outercore
+
+ character(len=150) LOCAL_PATH
+
+ ! local parameters
+ real(kind=CUSTOM_REAL):: scale_kl
+ real(kind=CUSTOM_REAL) :: rhol,kappal,rho_kl,alpha_kl,beta_kl
+ integer :: ispec,i,j,k
+ character(len=150) prname
+
+ scale_kl = scale_t/scale_displ * 1.d9
+
+ ! outer_core
+ do ispec = 1, NSPEC_OUTER_CORE
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ rhol = rhostore_outer_core(i,j,k,ispec)
+ kappal = kappavstore_outer_core(i,j,k,ispec)
+ rho_kl = - rhol * rho_kl_outer_core(i,j,k,ispec)
+ alpha_kl = - kappal * alpha_kl_outer_core(i,j,k,ispec)
+
+ rho_kl_outer_core(i,j,k,ispec) = (rho_kl + alpha_kl) * scale_kl
+ alpha_kl_outer_core(i,j,k,ispec) = 2 * alpha_kl * scale_kl
+
+
+ !deviatoric kernel check
+ if( deviatoric_outercore ) then
+ beta_kl = - 2 * beta_kl_outer_core(i,j,k,ispec) ! not using mul, since it's zero for the fluid
+ beta_kl_outer_core(i,j,k,ispec) = beta_kl
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ call create_name_database(prname,myrank,IREGION_OUTER_CORE,LOCAL_PATH)
+ open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) rho_kl_outer_core
+ close(27)
+ open(unit=27,file=trim(prname)//'alpha_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) alpha_kl_outer_core
+ close(27)
+
+ !deviatoric kernel check
+ if( deviatoric_outercore ) then
+ open(unit=27,file=trim(prname)//'mu_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) beta_kl_outer_core
+ close(27)
+ endif
+
+ end subroutine save_kernels_outer_core
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine save_kernels_inner_core(myrank,scale_t,scale_displ, &
+ rho_kl_inner_core,beta_kl_inner_core,alpha_kl_inner_core, &
+ rhostore_inner_core,muvstore_inner_core,kappavstore_inner_core, &
+ LOCAL_PATH)
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ double precision :: scale_t,scale_displ
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
+ rho_kl_inner_core, beta_kl_inner_core, alpha_kl_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
+ rhostore_inner_core, kappavstore_inner_core,muvstore_inner_core
+
+ character(len=150) LOCAL_PATH
+
+ ! local parameters
+ real(kind=CUSTOM_REAL):: scale_kl
+ real(kind=CUSTOM_REAL) :: rhol,mul,kappal,rho_kl,alpha_kl,beta_kl
+ integer :: ispec,i,j,k
+ character(len=150) prname
+
+
+ scale_kl = scale_t/scale_displ * 1.d9
+
+ ! inner_core
+ do ispec = 1, NSPEC_INNER_CORE
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ rhol = rhostore_inner_core(i,j,k,ispec)
+ mul = muvstore_inner_core(i,j,k,ispec)
+ kappal = kappavstore_inner_core(i,j,k,ispec)
+
+ rho_kl = -rhol * rho_kl_inner_core(i,j,k,ispec)
+ alpha_kl = -kappal * alpha_kl_inner_core(i,j,k,ispec)
+ beta_kl = - 2 * mul * beta_kl_inner_core(i,j,k,ispec)
+
+ rho_kl_inner_core(i,j,k,ispec) = (rho_kl + alpha_kl + beta_kl) * scale_kl
+ beta_kl_inner_core(i,j,k,ispec) = 2 * (beta_kl - FOUR_THIRDS * mul * alpha_kl / kappal) * scale_kl
+ alpha_kl_inner_core(i,j,k,ispec) = 2 * (1 + FOUR_THIRDS * mul / kappal) * alpha_kl * scale_kl
+ enddo
+ enddo
+ enddo
+ enddo
+
+ call create_name_database(prname,myrank,IREGION_INNER_CORE,LOCAL_PATH)
+ open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) rho_kl_inner_core
+ close(27)
+ open(unit=27,file=trim(prname)//'alpha_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) alpha_kl_inner_core
+ close(27)
+ open(unit=27,file=trim(prname)//'beta_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) beta_kl_inner_core
+ close(27)
+
+ end subroutine save_kernels_inner_core
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine save_kernels_boundary_kl(myrank,scale_t,scale_displ, &
+ moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl, &
+ LOCAL_PATH,HONOR_1D_SPHERICAL_MOHO)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ double precision :: scale_t,scale_displ
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO) :: moho_kl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_400) :: d400_kl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_670) :: d670_kl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_CMB) :: cmb_kl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_ICB) :: icb_kl
+
+ character(len=150) LOCAL_PATH
+
+ logical HONOR_1D_SPHERICAL_MOHO
+
+ ! local parameters
+ real(kind=CUSTOM_REAL):: scale_kl
+ character(len=150) prname
+
+
+ scale_kl = scale_t/scale_displ * 1.d9
+
+ ! scale the boundary kernels properly: *scale_kl gives s/km^3 and 1.d3 gives
+ ! the relative boundary kernels (for every 1 km) in s/km^2
+ moho_kl = moho_kl * scale_kl * 1.d3
+ d400_kl = d400_kl * scale_kl * 1.d3
+ d670_kl = d670_kl * scale_kl * 1.d3
+ cmb_kl = cmb_kl * scale_kl * 1.d3
+ icb_kl = icb_kl * scale_kl * 1.d3
+
+ call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
+
+ if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
+ open(unit=27,file=trim(prname)//'moho_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) moho_kl
+ close(27)
+ endif
+
+ open(unit=27,file=trim(prname)//'d400_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) d400_kl
+ close(27)
+
+ open(unit=27,file=trim(prname)//'d670_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) d670_kl
+ close(27)
+
+ open(unit=27,file=trim(prname)//'CMB_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) cmb_kl
+ close(27)
+
+ call create_name_database(prname,myrank,IREGION_OUTER_CORE,LOCAL_PATH)
+
+ open(unit=27,file=trim(prname)//'ICB_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) icb_kl
+ close(27)
+
+
+ end subroutine save_kernels_boundary_kl
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine save_kernels_source_derivatives(nrec_local,NSOURCES,scale_displ,scale_t, &
+ nu_source,moment_der,sloc_der,stshift_der,shdur_der,number_receiver_global)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer nrec_local,NSOURCES
+ double precision :: scale_displ,scale_t
+
+ double precision :: nu_source(NDIM,NDIM,NSOURCES)
+ real(kind=CUSTOM_REAL) :: moment_der(NDIM,NDIM,nrec_local),sloc_der(NDIM,nrec_local), &
+ stshift_der(nrec_local),shdur_der(nrec_local)
+
+ integer, dimension(nrec_local) :: number_receiver_global
+
+ ! local parameters
+ real(kind=CUSTOM_REAL),parameter :: scale_mass = RHOAV * (R_EARTH**3)
+ integer :: irec_local
+ character(len=150) outputname
+
+ !scale_mass = RHOAV * (R_EARTH**3)
+
+ do irec_local = 1, nrec_local
+ ! rotate and scale the location derivatives to correspond to dn,de,dz
+ sloc_der(:,irec_local) = matmul(transpose(nu_source(:,:,irec_local)),sloc_der(:,irec_local)) &
+ * scale_displ * scale_t
+
+ ! rotate scale the moment derivatives to correspond to M[n,e,z][n,e,z]
+ moment_der(:,:,irec_local) = matmul(matmul(transpose(nu_source(:,:,irec_local)),moment_der(:,:,irec_local)),&
+ nu_source(:,:,irec_local)) * scale_t ** 3 / scale_mass
+
+ ! derivatives for time shift and hduration
+ stshift_der(irec_local) = stshift_der(irec_local) * scale_displ**2
+ shdur_der(irec_local) = shdur_der(irec_local) * scale_displ**2
+
+ write(outputname,'(a,i5.5)') 'OUTPUT_FILES/src_frechet.',number_receiver_global(irec_local)
+ open(unit=27,file=trim(outputname),status='unknown',action='write')
+ !
+ ! r -> z, theta -> -n, phi -> e, plus factor 2 for Mrt,Mrp,Mtp, and 1e-7 to dyne.cm
+ ! Mrr = Mzz
+ ! Mtt = Mnn
+ ! Mpp = Mee
+ ! Mrt = -Mzn
+ ! Mrp = Mze
+ ! Mtp = -Mne
+ ! for consistency, location derivatives are in the order of [Xr,Xt,Xp]
+ ! minus sign for sloc_der(3,irec_local) to get derivative for depth instead of radius
+
+ write(27,'(g16.5)') moment_der(3,3,irec_local) * 1e-7
+ write(27,'(g16.5)') moment_der(1,1,irec_local) * 1e-7
+ write(27,'(g16.5)') moment_der(2,2,irec_local) * 1e-7
+ write(27,'(g16.5)') -2*moment_der(1,3,irec_local) * 1e-7
+ write(27,'(g16.5)') 2*moment_der(2,3,irec_local) * 1e-7
+ write(27,'(g16.5)') -2*moment_der(1,2,irec_local) * 1e-7
+ write(27,'(g16.5)') sloc_der(2,irec_local)
+ write(27,'(g16.5)') sloc_der(1,irec_local)
+ write(27,'(g16.5)') -sloc_der(3,irec_local)
+ write(27,'(g16.5)') stshift_der(irec_local)
+ write(27,'(g16.5)') shdur_der(irec_local)
+ close(27)
+ enddo
+
+
+ end subroutine save_kernels_source_derivatives
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine save_kernels_hessian(myrank,scale_t,scale_displ, &
+ hess_kl_crust_mantle,LOCAL_PATH)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ double precision :: scale_t,scale_displ
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
+ hess_kl_crust_mantle
+
+ character(len=150) LOCAL_PATH
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: scale_kl
+ character(len=150) prname
+
+ ! scaling factors
+ scale_kl = scale_t/scale_displ * 1.d9
+
+ ! scales approximate hessian
+ hess_kl_crust_mantle(:,:,:,:) = 2._CUSTOM_REAL * hess_kl_crust_mantle(:,:,:,:) * scale_kl
+
+ ! stores into file
+ call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
+ open(unit=27,file=trim(prname)//'hess_kernel.bin',status='unknown',form='unformatted',action='write')
+ write(27) hess_kl_crust_mantle
+ close(27)
+
+ end subroutine save_kernels_hessian
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/setup_sources_receivers.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/setup_sources_receivers.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/setup_sources_receivers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/setup_sources_receivers.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,593 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine setup_sources_receivers(NSOURCES,myrank,ibool_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xigll,yigll,zigll,TOPOGRAPHY, &
+ sec,tshift_cmt,theta_source,phi_source, &
+ NSTEP,DT,hdur,hdur_gaussian,t0,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, &
+ rec_filename,nrec,islice_selected_rec,ispec_selected_rec, &
+ xi_receiver,eta_receiver,gamma_receiver,station_name,network_name, &
+ stlat,stlon,stele,stbur,nu, &
+ nrec_local,nadj_rec_local,nrec_simulation, &
+ SIMULATION_TYPE,RECEIVERS_CAN_BE_BURIED,MOVIE_SURFACE,MOVIE_VOLUME, &
+ HDUR_MOVIE,OUTPUT_FILES,LOCAL_PATH)
+
+
+ implicit none
+
+ include 'mpif.h'
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer NSOURCES,myrank
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ logical TOPOGRAPHY
+
+ double precision sec,DT,t0,min_tshift_cmt_original
+
+ double precision, dimension(NSOURCES) :: tshift_cmt,hdur,hdur_gaussian
+ double precision, dimension(NSOURCES) :: theta_source,phi_source
+ double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source,nu_source
+
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ integer NSTEP
+
+ ! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ integer NEX_XI
+ logical PRINT_SOURCE_TIME_FUNCTION
+
+ character(len=150) rec_filename
+
+ integer nrec
+ integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+
+ double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ double precision, dimension(nrec) :: stlat,stlon,stele,stbur
+ double precision, dimension(NDIM,NDIM,nrec) :: nu
+
+ integer nrec_local,nadj_rec_local,nrec_simulation
+
+ integer SIMULATION_TYPE
+
+ logical RECEIVERS_CAN_BE_BURIED,MOVIE_SURFACE,MOVIE_VOLUME
+
+ double precision HDUR_MOVIE
+
+ character(len=150) OUTPUT_FILES
+ character(len=150) LOCAL_PATH
+
+ ! local parameters
+ double precision :: junk
+ integer :: yr,jda,ho,mi
+ integer :: irec,isource,nrec_tot_found,ier
+ integer :: icomp,itime,nadj_files_found,nadj_files_found_tot
+ character(len=3),dimension(NDIM) :: comp
+ character(len=150) :: filename,adj_source_file,system_command,filename_new
+ character(len=2) :: bic
+
+! sources
+ ! BS BS moved open statement and writing of first lines into sr.vtk before the
+ ! call to locate_sources, where further write statements to that file follow
+ if(myrank == 0) then
+ ! write source and receiver VTK files for Paraview
+ filename = trim(OUTPUT_FILES)//'/sr_tmp.vtk'
+ open(IOVTK,file=trim(filename),status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 2.0'
+ write(IOVTK,'(a)') 'Source and Receiver VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ ! LQY -- won't be able to know NSOURCES+nrec at this point...
+ write(IOVTK, '(a,i6,a)') 'POINTS ', NSOURCES, ' float'
+ 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_VAL,ELLIPTICITY_VAL,TOPOGRAPHY, &
+ sec,tshift_cmt,min_tshift_cmt_original,yr,jda,ho,mi,theta_source,phi_source, &
+ NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source, nu_source, &
+ rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION, &
+ LOCAL_PATH,SIMULATION_TYPE)
+
+ if(abs(minval(tshift_cmt)) > TINYVAL) call exit_MPI(myrank,'one tshift_cmt must be zero, others must be positive')
+
+ ! filter source time function by Gaussian with hdur = HDUR_MOVIE when outputing movies or shakemaps
+ if (MOVIE_SURFACE .or. MOVIE_VOLUME ) then
+ hdur = sqrt(hdur**2 + HDUR_MOVIE**2)
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Each source is being convolved with HDUR_MOVIE = ',HDUR_MOVIE
+ write(IMAIN,*)
+ endif
+ endif
+
+ ! convert the half duration for triangle STF to the one for gaussian STF
+ hdur_gaussian(:) = hdur(:)/SOURCE_DECAY_MIMIC_TRIANGLE
+
+ ! define t0 as the earliest start time
+ t0 = - 1.5d0*minval( tshift_cmt(:) - hdur(:) )
+
+ ! point force sources will start depending on the frequency given by hdur
+ if( USE_FORCE_POINT_SOURCE ) then
+ ! note: point force sources will give the dominant frequency in hdur,
+ ! thus the main period is 1/hdur.
+ ! also, these sources use a Ricker source time function instead of a gaussian.
+ ! for a Ricker source time function, a start time ~1.2 * main_period is a good choice
+ t0 = - 1.2d0 * minval(tshift_cmt(:) - 1.0d0/hdur(:))
+ endif
+
+ ! checks if user set USER_T0 to fix simulation start time
+ ! note: USER_T0 has to be positive
+ if( USER_T0 > 0.d0 ) then
+ ! user cares about origin time and time shifts of the CMTSOLUTION
+ ! and wants to fix simulation start time to a constant start time
+ ! time 0 on time axis will correspond to given origin time
+
+ ! notifies user
+ if( myrank == 0 ) then
+ write(IMAIN,*) 'USER_T0: ',USER_T0
+ write(IMAIN,*) 't0: ',t0,'min_tshift_cmt_original: ',min_tshift_cmt_original
+ write(IMAIN,*)
+ endif
+
+ ! checks if automatically set t0 is too small
+ ! note: min_tshift_cmt_original can be a positive or negative time shift (minimum from all tshift)
+ if( t0 <= USER_T0 + min_tshift_cmt_original ) then
+ ! by default, tshift_cmt(:) holds relative time shifts with a minimum time shift set to zero
+ ! re-adds (minimum) original time shift such that sources will kick in
+ ! according to their absolute time shift
+ tshift_cmt(:) = tshift_cmt(:) + min_tshift_cmt_original
+
+ ! sets new simulation start time such that
+ ! simulation starts at t = - t0 = - USER_T0
+ t0 = USER_T0
+
+ ! notifies user
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' set new simulation start time: ', - t0
+ write(IMAIN,*)
+ endif
+ else
+ ! start time needs to be at least t0 for numerical stability
+ ! notifies user
+ if( myrank == 0 ) then
+ write(IMAIN,*) 'error: USER_T0 is too small'
+ write(IMAIN,*) ' must make one of three adjustements:'
+ write(IMAIN,*) ' - increase USER_T0 to be at least: ',t0-min_tshift_cmt_original
+ write(IMAIN,*) ' - decrease time shift in CMTSOLUTION file'
+ write(IMAIN,*) ' - decrease hdur in CMTSOLUTION file'
+ endif
+ call exit_mpi(myrank,'error USER_T0 is set but too small')
+ endif
+ else if( USER_T0 < 0.d0 ) then
+ if( myrank == 0 ) then
+ write(IMAIN,*) 'error: USER_T0 is negative, must be set zero or positive!'
+ endif
+ call exit_mpi(myrank,'error negative USER_T0 parameter in constants.h')
+ endif
+
+ ! receivers
+ if(myrank == 0) then
+ write(IMAIN,*)
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ write(IMAIN,*) 'Total number of receivers = ', nrec
+ else
+ write(IMAIN,*) 'Total number of adjoint sources = ', nrec
+ endif
+ write(IMAIN,*)
+ 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,stbur,nu, &
+ yr,jda,ho,mi,sec,NPROCTOT_VAL,ELLIPTICITY_VAL,TOPOGRAPHY, &
+ theta_source(1),phi_source(1),rspl,espl,espl2,nspl, &
+ ibathy_topo,RECEIVERS_CAN_BE_BURIED,NCHUNKS_VAL)
+
+
+ ! count number of receivers located in this slice
+ nrec_local = 0
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ nrec_simulation = nrec
+ do irec = 1,nrec
+ if(myrank == islice_selected_rec(irec)) nrec_local = nrec_local + 1
+ enddo
+ else
+ nrec_simulation = NSOURCES
+ do isource = 1, NSOURCES
+ if(myrank == islice_selected_source(isource)) nrec_local = nrec_local + 1
+ enddo
+ endif
+
+ ! counts receivers for adjoint simulations
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+ ! by Ebru
+ call band_instrument_code(DT,bic)
+ comp(1) = bic(1:2)//'N'
+ comp(2) = bic(1:2)//'E'
+ comp(3) = bic(1:2)//'Z'
+
+ ! counter for adjoint receiver stations in local slice, used to allocate adjoint source arrays
+ nadj_rec_local = 0
+ ! temporary counter to check if any files are found at all
+ nadj_files_found = 0
+ do irec = 1,nrec
+ if(myrank == islice_selected_rec(irec))then
+ ! adjoint receiver station in this process slice
+ if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROCTOT_VAL-1) &
+ call exit_MPI(myrank,'something is wrong with the source slice number in adjoint simulation')
+
+ ! updates counter
+ nadj_rec_local = nadj_rec_local + 1
+
+ ! checks **sta**.**net**.**MX**.adj files for correct number of time steps
+ adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+ do icomp = 1,NDIM
+
+ ! opens adjoint source file for this component
+ filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit=IIN,file=trim(filename),status='old',action='read',iostat=ier)
+
+ if( ier == 0 ) then
+ ! checks length of file
+ itime = 0
+ do while(ier == 0)
+ read(IIN,*,iostat=ier) junk,junk
+ if( ier == 0 ) itime = itime + 1
+ enddo
+ if( itime /= NSTEP) &
+ call exit_MPI(myrank,&
+ 'file '//trim(filename)//' has wrong length, please check with your simulation duration')
+
+ ! updates counter for found files
+ nadj_files_found = nadj_files_found + 1
+ else
+ ! adjoint source file not found
+ ! stops simulation
+ call exit_MPI(myrank,&
+ 'file '//trim(filename)//' not found, please check with your STATIONS_ADJOINT file')
+ endif
+ close(IIN)
+ enddo
+ endif
+ enddo
+
+ ! checks if any adjoint source files found at all
+ call MPI_REDUCE(nadj_files_found,nadj_files_found_tot,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' ',nadj_files_found_tot,' adjoint component traces found in all slices'
+ if(nadj_files_found_tot == 0) &
+ call exit_MPI(myrank,'no adjoint traces found, please check adjoint sources in directory SEM/')
+ endif
+ endif
+
+ ! 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 slices'
+ if(nrec_tot_found /= nrec_simulation) then
+ call exit_MPI(myrank,'problem when dispatching the receivers')
+ else
+ write(IMAIN,*) 'this total is okay'
+ endif
+ endif
+
+ ! user output
+ if(myrank == 0) then
+
+ ! finishes vtk file
+ write(IOVTK,*) ""
+ close(IOVTK)
+
+ ! we should know NSOURCES+nrec at this point...
+ filename = trim(OUTPUT_FILES)//'/sr_tmp.vtk'
+ filename_new = trim(OUTPUT_FILES)//'/sr.vtk'
+ write(system_command,"('sed -e ',a1,'s/POINTS.*/POINTS',i6,' float/',a1,' < ',a,' > ',a)") &
+ "'",NSOURCES + nrec,"'",trim(filename),trim(filename_new)
+ call system(system_command)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP
+ write(IMAIN,*)
+
+
+ if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
+ endif
+
+ end subroutine setup_sources_receivers
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine setup_sources_receivers_srcarr(NSOURCES,myrank, &
+ ispec_selected_source,islice_selected_source, &
+ xi_source,eta_source,gamma_source, &
+ Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ 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,sourcearrays)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer NSOURCES,myrank
+
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+
+ 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
+
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES) :: sourcearrays
+
+
+ ! local parameters
+ integer :: isource
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+
+ do isource = 1,NSOURCES
+
+ ! check that the source slice number is okay
+ if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROCTOT_VAL-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
+
+ end subroutine setup_sources_receivers_srcarr
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine setup_sources_receivers_adjindx(NSTEP,NSTEP_SUB_ADJ, &
+ NTSTEP_BETWEEN_READ_ADJSRC, &
+ iadjsrc,iadjsrc_len,iadj_vec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer NSTEP,NSTEP_SUB_ADJ,NTSTEP_BETWEEN_READ_ADJSRC
+
+ integer, dimension(NSTEP_SUB_ADJ,2) :: iadjsrc ! to read input in chunks
+ integer, dimension(NSTEP_SUB_ADJ) :: iadjsrc_len
+ integer, dimension(NSTEP) :: iadj_vec
+
+
+ ! local parameters
+ integer :: iadj_block,it,it_sub_adj
+
+ iadj_block = 1 !counts blocks
+
+ iadjsrc(:,:) = 0
+ iadjsrc_len(:) = 0
+
+ ! setting up chunks of NTSTEP_BETWEEN_READ_ADJSRC to read adjoint source traces
+ ! i.e. as an example: total length NSTEP = 3000, chunk length NTSTEP_BETWEEN_READ_ADJSRC= 1000
+ ! then it will set first block from 2001 to 3000,
+ ! second block from 1001 to 2000 and so on...
+ !
+ ! see routine: compute_arrays_source_adjoint()
+ ! how we read in the adjoint source trace in blocks/chunk sizes
+ !
+ ! see routine: compute_add_sources_adjoint()
+ ! how the adjoint source is added to the (adjoint) acceleration field
+ do it=1,NSTEP
+
+ ! block number
+ ! e.g. increases from 1 (case it=1-1000), 2 (case it=1001-2000) to 3 (case it=2001-3000)
+ it_sub_adj = ceiling( dble(it)/dble(NTSTEP_BETWEEN_READ_ADJSRC) )
+
+ ! we are at the edge of a block
+ if(mod(it-1,NTSTEP_BETWEEN_READ_ADJSRC) == 0) then
+ ! block start time ( e.g. 2001)
+ iadjsrc(iadj_block,1) = NSTEP-it_sub_adj*NTSTEP_BETWEEN_READ_ADJSRC+1
+ ! block end time (e.g. 3000)
+ iadjsrc(iadj_block,2) = NSTEP-(it_sub_adj-1)*NTSTEP_BETWEEN_READ_ADJSRC
+
+ ! final adj src array
+ ! e.g. will be from 1000 to 1, but doesn't go below 1 in cases where NSTEP isn't
+ ! a multiple of NTSTEP_BETWEEN_READ_ADJSRC
+ if(iadjsrc(iadj_block,1) < 0) iadjsrc(iadj_block,1) = 1
+
+ ! actual block length
+ iadjsrc_len(iadj_block) = iadjsrc(iadj_block,2)-iadjsrc(iadj_block,1)+1
+
+ ! increases block number
+ iadj_block = iadj_block+1
+ endif
+
+ ! time stepping for adjoint sources:
+ ! adjoint time step that corresponds to time step in simulation (it).
+ ! note, that adjoint source has to be time-reversed with respect to the forward wavefield
+ ! e.g.: first block 1 has iadjsrc_len = 1000 with start at 2001 and end at 3000
+ ! so iadj_vec(1) = 1000 - 0, iadj_vec(2) = 1000 - 1, ..., to iadj_vec(1000) = 1000 - 999 = 1
+ ! then for block 2, iadjsrc_len = 1000 with start at 1001 and end at 2000
+ ! so iadj_vec(1001) = 1000 - 0, iad_vec(1002) = 1000 - 1, .. and so on again down to 1
+ ! then block 3 and your guess is right now... iadj_vec(2001) to iadj_vec(3000) is 1000 down to 1. :)
+ iadj_vec(it) = iadjsrc_len(it_sub_adj) - mod(it-1,NTSTEP_BETWEEN_READ_ADJSRC)
+ enddo
+
+ end subroutine setup_sources_receivers_adjindx
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine setup_sources_receivers_intp(NSOURCES,myrank, &
+ islice_selected_source, &
+ xi_source,eta_source,gamma_source, &
+ xigll,yigll,zigll, &
+ SIMULATION_TYPE,nrec,nrec_local, &
+ islice_selected_rec,number_receiver_global, &
+ xi_receiver,eta_receiver,gamma_receiver, &
+ hxir_store,hetar_store,hgammar_store, &
+ nadj_hprec_local,hpxir_store,hpetar_store,hpgammar_store)
+
+ implicit none
+
+ include "constants.h"
+
+ integer NSOURCES,myrank
+
+ integer, dimension(NSOURCES) :: islice_selected_source
+
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+
+ integer SIMULATION_TYPE
+
+ integer nrec,nrec_local
+ integer, dimension(nrec) :: islice_selected_rec
+ integer, dimension(nrec_local) :: number_receiver_global
+ double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
+
+ double precision, dimension(nrec_local,NGLLX) :: hxir_store
+ double precision, dimension(nrec_local,NGLLY) :: hetar_store
+ double precision, dimension(nrec_local,NGLLZ) :: hgammar_store
+
+ integer nadj_hprec_local
+ double precision, dimension(nadj_hprec_local,NGLLX) :: hpxir_store
+ double precision, dimension(nadj_hprec_local,NGLLY) :: hpetar_store
+ double precision, dimension(nadj_hprec_local,NGLLZ) :: hpgammar_store
+
+
+ ! local parameters
+ integer :: isource,irec,irec_local
+ double precision, dimension(NGLLX) :: hxir,hpxir
+ double precision, dimension(NGLLY) :: hpetar,hetar
+ double precision, dimension(NGLLZ) :: hgammar,hpgammar
+
+
+ ! select local receivers
+
+ ! define local to global receiver numbering mapping
+ irec_local = 0
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ do irec = 1,nrec
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+ number_receiver_global(irec_local) = irec
+ endif
+ enddo
+ else
+ do isource = 1,NSOURCES
+ if(myrank == islice_selected_source(isource)) then
+ irec_local = irec_local + 1
+ number_receiver_global(irec_local) = isource
+ endif
+ enddo
+ endif
+
+ ! define and store Lagrange interpolators at all the receivers
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ 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
+ else
+ do irec_local = 1,nrec_local
+ irec = number_receiver_global(irec_local)
+ call lagrange_any(xi_source(irec),NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_source(irec),NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_source(irec),NGLLZ,zigll,hgammar,hpgammar)
+ hxir_store(irec_local,:) = hxir(:)
+ hetar_store(irec_local,:) = hetar(:)
+ hgammar_store(irec_local,:) = hgammar(:)
+ hpxir_store(irec_local,:) = hpxir(:)
+ hpetar_store(irec_local,:) = hpetar(:)
+ hpgammar_store(irec_local,:) = hpgammar(:)
+ enddo
+ endif
+
+ end subroutine setup_sources_receivers_intp
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/sort_array_coordinates.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/sort_array_coordinates.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/sort_array_coordinates.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/sort_array_coordinates.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! 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/src/specfem3D.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/specfem3D.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,4385 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ program xspecfem3D
+
+ 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 at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{VaCaSaKoVi99,
+! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
+! D. Komatitsch and J. P. Vilotte},
+! title = {Elastic wave propagation in an irregularly layered medium},
+! journal = {Soil Dynamics and Earthquake Engineering},
+! year = {1999},
+! volume = {18},
+! pages = {11-18},
+! number = {1},
+! doi = {10.1016/S0267-7261(98)00027-X}}
+!
+! @ARTICLE{LeChKoHuTr09,
+! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
+! Shouh Huang and Jeroen Tromp},
+! title = {Effects of realistic surface topography on seismic ground motion
+! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
+! method and {LiDAR DTM}},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2009},
+! volume = {99},
+! pages = {681-693},
+! number = {2A},
+! doi = {10.1785/0120080264}}
+!
+! @ARTICLE{LeChLiKoHuTr08,
+! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
+! and Bor Shouh Huang and Jeroen Tromp},
+! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
+! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2008},
+! volume = {98},
+! pages = {253-264},
+! number = {1},
+! doi = {10.1785/0120070033}}
+!
+! @ARTICLE{LeKoHuTr09,
+! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
+! title = {Effects of topography on seismic wave propagation: An example from
+! northern {T}aiwan},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2009},
+! volume = {99},
+! pages = {314-325},
+! number = {1},
+! doi = {10.1785/0120080020}}
+!
+! @ARTICLE{KoErGoMi10,
+! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
+! David Mich\'ea},
+! title = {High-order finite-element seismic wave propagation modeling with
+! {MPI} on a large {GPU} cluster},
+! journal = {J. Comput. Phys.},
+! year = {2010},
+! volume = {229},
+! pages = {7692-7714},
+! number = {20},
+! doi = {10.1016/j.jcp.2010.06.024}}
+!
+! @ARTICLE{KoGoErMi10,
+! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
+! David Mich\'ea},
+! title = {Modeling the propagation of elastic waves using spectral elements
+! on a cluster of 192 {GPU}s},
+! journal = {Computer Science Research and Development},
+! year = {2010},
+! volume = {25},
+! pages = {75-82},
+! number = {1-2},
+! doi = {10.1007/s00450-010-0109-1}}
+!
+! @ARTICLE{KoMiEr09,
+! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
+! title = {Porting a high-order finite-element earthquake modeling application
+! to {NVIDIA} graphics cards using {CUDA}},
+! journal = {Journal of Parallel and Distributed Computing},
+! year = {2009},
+! volume = {69},
+! pages = {451-460},
+! number = {5},
+! doi = {10.1016/j.jpdc.2009.01.006}}
+!
+! @INCOLLECTION{ChKoViCaVaFe07,
+! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
+! Yann Capdeville and Bernard Valette and Gaetano Festa},
+! title = {Spectral Element Analysis in Seismology},
+! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
+! publisher = {Elsevier - Academic Press},
+! year = {2007},
+! editor = {Ru-Shan Wu and Val\'erie Maupin},
+! volume = {48},
+! series = {Advances in Geophysics},
+! pages = {365-419}}
+!
+! @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}}
+!
+! @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{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}}
+!
+! and/or another article from http://web.univ-pau.fr/~dkomati1/publications.html
+!
+!
+! If you use the kernel capabilities of the code, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! If you use 3-D model S20RTS, please cite:
+!
+! @ARTICLE{RiVa00,
+! author={J. Ritsema and H. J. {Van Heijst}},
+! year=2000,
+! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
+! journal={Science Progress},
+! volume=83,
+! pages={243-259}}
+!
+! Reference frame - convention:
+! ----------------------------
+!
+! The code uses the following convention for the reference frame:
+!
+! - X axis is East
+! - Y axis is North
+! - Z axis is up
+!
+! Note that this convention is different from both the Aki-Richards convention
+! and the Harvard CMT convention.
+!
+! Let us recall that the Aki-Richards convention is:
+!
+! - X axis is North
+! - Y axis is East
+! - Z axis is down
+!
+! and that the Harvard CMT convention is:
+!
+! - X axis is South
+! - Y axis is East
+! - Z axis is up
+!
+! To report bugs or suggest improvements to the code, please send an email
+! to Jeroen Tromp <jtromp AT princeton.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+! Evolution of the code:
+! ---------------------
+!
+! v. 5.1, Dimitri Komatitsch, University of Toulouse, France and Ebru Bozdag, Princeton University, USA, February 2011:
+! non blocking MPI for much better scaling on large clusters;
+! new convention for the name of seismograms, to conform to the IRIS standard;
+! new directory structure
+!
+! v. 5.0 aka Tiger, many developers some with Princeton Tiger logo on their shirts, February 2010:
+! new moho mesh stretching honoring crust2.0 moho depths,
+! new attenuation assignment, new SAC headers, new general crustal models,
+! faster performance due to Deville routines and enhanced loop unrolling,
+! slight changes in code structure (see also trivia at program start)
+!
+! 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, one more doubling level at the bottom
+! of the outer core if needed (off by default)
+!
+! 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 CM-5 Connection Machine
+!
+! 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.
+
+! memory variables and standard linear solids for attenuation
+ real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT4) :: one_minus_sum_beta_crust_mantle, factor_scale_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT5) :: one_minus_sum_beta_inner_core, factor_scale_inner_core
+
+ 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
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: epsilondev_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: eps_trace_over_3_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory_inner_core
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: epsilondev_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STRAIN_ONLY) :: eps_trace_over_3_inner_core
+
+! ADJOINT
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: b_alphaval, b_betaval, b_gammaval
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: b_R_memory_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: b_epsilondev_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: b_eps_trace_over_3_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: b_R_memory_inner_core
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: b_epsilondev_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: b_eps_trace_over_3_inner_core
+
+! for matching with central cube in inner core
+ integer, dimension(:), allocatable :: sender_from_slices_to_cube
+ integer, dimension(:,:), allocatable :: ibool_central_cube
+ double precision, dimension(:,:), allocatable :: buffer_slices,b_buffer_slices,buffer_slices2
+ double precision, dimension(:,:,:), allocatable :: buffer_all_cube_from_slices,b_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
+
+! to save movie frames
+ integer nmovie_points,NIT
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_ux,store_val_uy,store_val_uz
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ store_val_x_all,store_val_y_all,store_val_z_all, &
+ store_val_ux_all,store_val_uy_all,store_val_uz_all
+
+! to save movie volume
+ integer :: npoints_3dmovie,nspecel_3dmovie
+ integer, dimension(NGLOB_CRUST_MANTLE) :: num_ibool_3dmovie
+ double precision :: scalingval
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: muvstore_crust_mantle_3dmovie
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: nu_3dmovie
+ logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: mask_3dmovie
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: Iepsilondev_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: Ieps_trace_over_3_crust_mantle
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! for crust/oceans coupling
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
+ integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+
+! additional mass matrix for ocean load
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
+
+! flag to mask ocean-bottom degrees of freedom for ocean load
+ logical, dimension(NGLOB_CRUST_MANTLE_OCEANS) :: updated_dof_ocean_load
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: jacobian2D_bottom_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: jacobian2D_top_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: jacobian2D_xmin_crust_mantle,&
+ jacobian2D_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_CM) :: jacobian2D_ymin_crust_mantle,&
+ jacobian2D_ymax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2DMAX_YMIN_YMAX_CM) :: &
+ normal_ymin_crust_mantle,normal_ymax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: normal_bottom_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
+
+! Stacey
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: rho_vp_crust_mantle,rho_vs_crust_mantle
+ integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle,nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
+ integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_CM) :: nimin_crust_mantle,nimax_crust_mantle,nkmin_eta_crust_mantle
+ integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_CM) :: njmin_crust_mantle,njmax_crust_mantle,nkmin_xi_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_STACEY) :: vp_outer_core
+ integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core,nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
+ integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_OC) :: nimin_outer_core,nimax_outer_core,nkmin_eta_outer_core
+ integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_OC) :: njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core
+
+! arrays to couple with the fluid regions by pointwise matching
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+ integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: normal_xmin_outer_core,normal_xmax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: normal_ymin_outer_core,normal_ymax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core
+
+
+ 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 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 NGLOB2DMAX_XY
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle, &
+ iboolfaces_outer_core,iboolfaces_inner_core
+
+! this for non blocking MPI
+
+! 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
+ integer :: npoin2D_max_all_CM_IC
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_send_faces,buffer_received_faces, &
+ b_buffer_send_faces,b_buffer_received_faces
+
+! for non blocking communications
+ logical, dimension(NSPEC_CRUST_MANTLE) :: is_on_a_slice_edge_crust_mantle
+ logical, dimension(NSPEC_OUTER_CORE) :: is_on_a_slice_edge_outer_core
+ logical, dimension(NSPEC_INNER_CORE) :: is_on_a_slice_edge_inner_core
+ logical, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool
+ real :: percentage_edge
+
+! assembling phase number for non blocking MPI
+! iphase is for the crust_mantle, outer_core and inner_core regions
+! iphase_CC is for the central cube
+ integer :: iphase,iphase_CC,icall
+ integer :: b_iphase,b_iphase_CC,b_icall
+
+! -------- 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) :: &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle
+
+! arrays for anisotropic elements stored only where needed to save space
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
+
+! arrays for full anisotropy only when needed
+ 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, &
+ 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
+
+! 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
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
+ rhostore_outer_core,kappavstore_outer_core
+
+! local to global mapping
+ integer, dimension(NSPEC_OUTER_CORE) :: idoubling_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, &
+ rhostore_inner_core, kappavstore_inner_core,muvstore_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core
+
+! arrays for inner-core anisotropy only when needed
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core
+
+! local to global mapping
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(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_t_inv,scale_displ,scale_veloc
+
+! ADJOINT
+ real(kind=CUSTOM_REAL) b_deltat,b_deltatover2,b_deltatsqover2
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: div_displ_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: b_div_displ_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: rho_kl_crust_mantle, &
+ beta_kl_crust_mantle, alpha_kl_crust_mantle, Sigma_kl_crust_mantle
+! For anisotropic kernels (see compute_kernels.f90 for a definition of the array)
+ real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: cijkl_kl_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: rho_kl_outer_core, &
+ alpha_kl_outer_core
+
+ ! approximate hessian
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: hess_kl_crust_mantle
+
+ ! check for deviatoric kernel for outer core region
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: beta_kl_outer_core
+ integer :: nspec_beta_kl_outer_core
+ logical,parameter:: deviatoric_outercore = .false.
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: rho_kl_inner_core, &
+ beta_kl_inner_core, alpha_kl_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: absorb_xmin_crust_mantle5, &
+ absorb_xmax_crust_mantle5, absorb_ymin_crust_mantle5, absorb_ymax_crust_mantle5
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: absorb_xmin_outer_core, &
+ absorb_xmax_outer_core, absorb_ymin_outer_core, absorb_ymax_outer_core, &
+ absorb_zmin_outer_core
+ integer nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm
+ integer nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc,nabs_zmin_oc
+
+ integer reclen_xmin_crust_mantle, reclen_xmax_crust_mantle, reclen_ymin_crust_mantle, &
+ reclen_ymax_crust_mantle, reclen_xmin_outer_core, reclen_xmax_outer_core,&
+ reclen_ymin_outer_core, reclen_ymax_outer_core, reclen_zmin
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_OUTER_CORE) :: vector_accel_outer_core,&
+ vector_displ_outer_core, b_vector_displ_outer_core
+
+ 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
+ integer, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
+ double precision, dimension(:,:,:) ,allocatable:: nu_source
+ double precision sec
+ double precision, dimension(:), allocatable :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision, dimension(:), allocatable :: xi_source,eta_source,gamma_source
+ double precision, dimension(:), allocatable :: tshift_cmt,hdur,hdur_gaussian
+ double precision, dimension(:), allocatable :: theta_source,phi_source
+ double precision, external :: comp_source_time_function
+ double precision t0
+
+! receiver information
+ integer nrec,nrec_local
+ integer, dimension(:), allocatable :: islice_selected_rec,ispec_selected_rec,number_receiver_global
+ double precision, dimension(:), allocatable :: xi_receiver,eta_receiver,gamma_receiver
+ character(len=150) :: STATIONS,rec_filename
+ double precision, dimension(:,:,:), allocatable :: nu
+ double precision, allocatable, dimension(:) :: stlat,stlon,stele,stbur
+ character(len=MAX_LENGTH_STATION_NAME), dimension(:), allocatable :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(:), allocatable :: network_name
+
+!ADJOINT
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: adj_sourcearrays
+ integer nrec_simulation, nadj_rec_local
+ integer NSTEP_SUB_ADJ ! to read input in chunks
+ integer, dimension(:,:), allocatable :: iadjsrc ! to read input in chunks
+ integer, dimension(:), allocatable :: iadjsrc_len,iadj_vec
+! source frechet derivatives
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: moment_der
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: sloc_der
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: stshift_der, shdur_der
+ double precision, dimension(:,:), allocatable :: hpxir_store,hpetar_store,hpgammar_store
+ integer :: nadj_hprec_local
+
+! seismograms
+ integer it_begin,it_end,nit_written
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms
+ integer :: seismo_offset, seismo_current
+
+! non-dimensionalized rotation rate of the Earth times two
+ real(kind=CUSTOM_REAL) two_omega_earth
+
+! for the Euler scheme for rotation
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
+ A_array_rotation,B_array_rotation
+
+! number of faces between chunks
+ integer 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_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_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_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_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(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+! Lagrange interpolators at receivers
+ 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
+
+ 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
+
+ integer ichunk,iproc_xi,iproc_eta
+
+!ADJOINT
+ real(kind=CUSTOM_REAL) b_two_omega_earth
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
+ b_A_array_rotation,b_B_array_rotation
+
+ double precision :: time_start
+
+! 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, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,&
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ ANGULAR_WIDTH_XI_IN_DEGREES
+
+ logical ONE_CRUST,TOPOGRAPHY,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH
+
+! logical COMPUTE_AND_STORE_STRAIN
+
+! for SAC headers for seismograms
+ integer yr_SAC,jda_SAC,ho_SAC,mi_SAC
+ real mb_SAC
+ double precision t_cmt_SAC,t_shift_SAC,elat_SAC,elon_SAC,depth_SAC, &
+ cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,sec_SAC
+ character(len=20) event_name_SAC
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+
+ character(len=150) prname
+
+! lookup table every km for gravity
+ real(kind=CUSTOM_REAL) minus_g_cmb,minus_g_icb
+ double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table, &
+ minus_deriv_gravity_table,density_table,d_ln_density_dr_table,minus_rho_g_over_kappa_fluid
+
+! dummy array that does not need to be actually read
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,1) :: dummy_array
+
+! computed in read_compute_parameters
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! Boundary Mesh and Kernels
+ integer k_top,k_bot,iregion_code
+ integer, dimension(NSPEC2D_MOHO) :: ibelm_moho_top,ibelm_moho_bot
+ integer, dimension(NSPEC2D_400) :: ibelm_400_top,ibelm_400_bot
+ integer, dimension(NSPEC2D_670) :: ibelm_670_top,ibelm_670_bot
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO) :: normal_moho
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_400) :: normal_400
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_670) :: normal_670
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO) :: moho_kl, moho_kl_top, moho_kl_bot
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_400) :: d400_kl, d400_kl_top, d400_kl_bot
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_670) :: d670_kl, d670_kl_top, d670_kl_bot
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_CMB) :: cmb_kl, cmb_kl_top, cmb_kl_bot
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_ICB) :: icb_kl, icb_kl_top, icb_kl_bot
+ logical :: fluid_solid_boundary
+
+ integer :: i,ier
+
+ integer :: imodulo_NGLOB_CRUST_MANTLE
+
+! NOISE_TOMOGRAPHY
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: noise_sourcearray
+ integer :: irec_master_noise
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
+ normal_x_noise,normal_y_noise,normal_z_noise, mask_noise
+
+! ************** PROGRAM STARTS HERE **************
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+! trivia about the programming style adopted here:
+!
+! note 1: for performance reasons, we try to use as much from the stack memory as possible.
+! This is done to avoid memory fragmentation and also to optimize performance.
+! Stack memory is a place in computer memory where all the variables that are declared
+! and initialized **before** runtime are stored. Our static array allocation will use that one.
+! All variables declared within our main routine also will be stored on the stack.
+!
+! the heap is the section of computer memory where all the variables created or initialized
+! **at** runtime are stored. it is used for dynamic memory allocation.
+!
+! stack is much faster than the heap.
+!
+! when calling a function, additional storage will be allocated for the variables in that function.
+! that storage will be allocated in the heap memory segment.
+!
+! most routine calls here will have rather long argument lists, probably because of this performance criteria.
+! using modules/common data blocks together with dynamic allocation will put data into heap memory,
+! thus it has longer latency to access variables than stack memory variables.
+!
+! however, declaring the static arrays needed in compute_forces_crust_mantle_Dev()
+! like e.g. sum_terms, tempx1,...B1_m1_m2_5points,... in this main routine and
+! passing them along as arguments to the routine makes the code slower.
+! it seems that this stack/heap criterion is more complicated.
+!
+! another reason why modules are avoided is to make the code thread safe.
+! having different threads access the same data structure and modifying it at the same time
+! would lead to problems. passing arguments is a way to avoid such complications.
+!
+! note 2: Most of the computation time is spent
+! inside the time loop (mainly in the compute_forces_crust_mantle_Dev() routine).
+! Any code performance tuning will be most effective in there.
+!
+! note 3: Fortran is a code language that uses column-first ordering for arrays,
+! e.g., it stores a(i,j) in this order: a(1,1),a(2,1),a(3,1),...,a(1,2),a(2,2),a(3,2),..
+! it is therefore more efficient to have the inner-loop over i, and the outer loop over j
+!
+! note 4: Deville et al. (2002) routines significantly reduce the total number of memory accesses
+! required to perform matrix-matrix products at the spectral element level.
+! For most compilers and hardware, will result in a significant speedup (> 30% or more, sometimes twice faster).
+!
+! note 5: a common technique to help compilers enhance pipelining is loop unrolling. We do this here in a simple
+! and straigthforward way, so don't be confused about the do-loop writing.
+!
+! note 6: whenever adding some new code, please make sure to use
+! spaces rather than tabs. Tabulators are in principle not allowed in Fortran95.
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+ ! initialize the MPI communicator and start the NPROCTOT MPI processes.
+ call MPI_INIT(ier)
+
+ ! initializes simulation parameters
+ call initialize_simulation(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,NEX_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,SIMULATION_TYPE, &
+ DT,ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670,R771,&
+ RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ HDUR_MOVIE,MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST, &
+ MOVIE_NORTH,MOVIE_SOUTH,MOVIE_SURFACE,MOVIE_VOLUME, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
+ OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
+ LOCAL_PATH,OUTPUT_FILES, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top, &
+ this_region_has_a_doubling,rmins,rmaxs, &
+ TOPOGRAPHY,HONOR_1D_SPHERICAL_MOHO,ONE_CRUST, &
+ nspl,rspl,espl,espl2,ibathy_topo, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ xigll,yigll,zigll,wxgll,wygll,wzgll,wgll_cube, &
+ hprime_xx,hprime_yy,hprime_zz,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ rec_filename,STATIONS,nrec,NOISE_TOMOGRAPHY)
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+! starts reading the databases
+ call read_mesh_databases(myrank,rho_vp_crust_mantle,rho_vs_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, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ nspec_iso,nspec_tiso,nspec_ani, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle,is_on_a_slice_edge_crust_mantle,rmass_crust_mantle,rmass_ocean_load, &
+ vp_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, &
+ rhostore_outer_core,kappavstore_outer_core, &
+ ibool_outer_core,idoubling_outer_core,is_on_a_slice_edge_outer_core,rmass_outer_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
+ c11store_inner_core,c12store_inner_core,c13store_inner_core, &
+ c33store_inner_core,c44store_inner_core, &
+ ibool_inner_core,idoubling_inner_core,is_on_a_slice_edge_inner_core,rmass_inner_core, &
+ ABSORBING_CONDITIONS,LOCAL_PATH)
+
+ ! read 2-D addressing for summation between slices with MPI
+ call read_mesh_databases_addressing(myrank, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, &
+ iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,npoin2D_faces_crust_mantle, &
+ iboolcorner_crust_mantle, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core, &
+ iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_xi_outer_core,npoin2D_eta_outer_core,&
+ iboolfaces_outer_core,npoin2D_faces_outer_core, &
+ iboolcorner_outer_core, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core, &
+ iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,npoin2D_faces_inner_core, &
+ iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ LOCAL_PATH,OUTPUT_FILES, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XY,NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
+ ichunk,iproc_xi,iproc_eta)
+
+ ! to couple mantle with outer core
+ call read_mesh_databases_coupling(myrank, &
+ 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, &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle,normal_ymin_crust_mantle, &
+ normal_ymax_crust_mantle,normal_bottom_crust_mantle,normal_top_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle,jacobian2D_ymin_crust_mantle, &
+ jacobian2D_ymax_crust_mantle,jacobian2D_bottom_crust_mantle,jacobian2D_top_crust_mantle, &
+ 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, &
+ normal_xmin_outer_core,normal_xmax_outer_core,normal_ymin_outer_core, &
+ normal_ymax_outer_core,normal_bottom_outer_core,normal_top_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core,jacobian2D_ymin_outer_core, &
+ jacobian2D_ymax_outer_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
+ 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, &
+ ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
+ ibelm_670_top,ibelm_670_bot,normal_moho,normal_400,normal_670, &
+ k_top,k_bot,moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl, &
+ LOCAL_PATH,SIMULATION_TYPE)
+
+! 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_CM_IC = max(maxval(npoin2D_xi_crust_mantle(:) + npoin2D_xi_inner_core(:)), &
+ maxval(npoin2D_eta_crust_mantle(:) + npoin2D_eta_inner_core(:)))
+
+ allocate(buffer_send_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED))
+ allocate(buffer_received_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED))
+
+ allocate(b_buffer_send_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED))
+ allocate(b_buffer_received_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED))
+
+ call fix_non_blocking_slices(is_on_a_slice_edge_crust_mantle,iboolright_xi_crust_mantle, &
+ iboolleft_xi_crust_mantle,iboolright_eta_crust_mantle,iboolleft_eta_crust_mantle, &
+ npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle,ibool_crust_mantle, &
+ mask_ibool,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM)
+
+ call fix_non_blocking_slices(is_on_a_slice_edge_outer_core,iboolright_xi_outer_core, &
+ iboolleft_xi_outer_core,iboolright_eta_outer_core,iboolleft_eta_outer_core, &
+ npoin2D_xi_outer_core,npoin2D_eta_outer_core,ibool_outer_core, &
+ mask_ibool,NSPEC_OUTER_CORE,NGLOB_OUTER_CORE,NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC)
+
+ call fix_non_blocking_slices(is_on_a_slice_edge_inner_core,iboolright_xi_inner_core, &
+ iboolleft_xi_inner_core,iboolright_eta_inner_core,iboolleft_eta_inner_core, &
+ npoin2D_xi_inner_core,npoin2D_eta_inner_core,ibool_inner_core, &
+ mask_ibool,NSPEC_INNER_CORE,NGLOB_INNER_CORE,NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC)
+
+ ! absorbing boundaries
+ if(ABSORBING_CONDITIONS) then
+ ! crust_mantle
+ if (nspec2D_xmin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ nabs_xmin_cm = nspec2D_xmin_crust_mantle
+ else
+ nabs_xmin_cm = 1
+ endif
+ allocate(absorb_xmin_crust_mantle5(NDIM,NGLLY,NGLLZ,nabs_xmin_cm,8))
+
+ if (nspec2D_xmax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ nabs_xmax_cm = nspec2D_xmax_crust_mantle
+ else
+ nabs_xmax_cm = 1
+ endif
+ allocate(absorb_xmax_crust_mantle5(NDIM,NGLLY,NGLLZ,nabs_xmax_cm,8))
+
+ if (nspec2D_ymin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ nabs_ymin_cm = nspec2D_ymin_crust_mantle
+ else
+ nabs_ymin_cm = 1
+ endif
+ allocate(absorb_ymin_crust_mantle5(NDIM,NGLLX,NGLLZ,nabs_ymin_cm,8))
+
+ if (nspec2D_ymax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ nabs_ymax_cm = nspec2D_ymax_crust_mantle
+ else
+ nabs_ymax_cm = 1
+ endif
+ allocate(absorb_ymax_crust_mantle5(NDIM,NGLLX,NGLLZ,nabs_ymax_cm,8))
+
+ ! outer_core
+ if (nspec2D_xmin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ nabs_xmin_oc = nspec2D_xmin_outer_core
+ else
+ nabs_xmin_oc = 1
+ endif
+ allocate(absorb_xmin_outer_core(NGLLY,NGLLZ,nabs_xmin_oc))
+
+ if (nspec2D_xmax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ nabs_xmax_oc = nspec2D_xmax_outer_core
+ else
+ nabs_xmax_oc = 1
+ endif
+ allocate(absorb_xmax_outer_core(NGLLY,NGLLZ,nabs_xmax_oc))
+
+ if (nspec2D_ymin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ nabs_ymin_oc = nspec2D_ymin_outer_core
+ else
+ nabs_ymin_oc = 1
+ endif
+ allocate(absorb_ymin_outer_core(NGLLX,NGLLZ,nabs_ymin_oc))
+
+ if (nspec2D_ymax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ nabs_ymax_oc = nspec2D_ymax_outer_core
+ else
+ nabs_ymax_oc = 1
+ endif
+ allocate(absorb_ymax_outer_core(NGLLX,NGLLZ,nabs_ymax_oc))
+
+ if (NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 .and. &
+ (SIMULATION_TYPE == 3 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ nabs_zmin_oc = NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
+ else
+ nabs_zmin_oc = 1
+ endif
+ allocate(absorb_zmin_outer_core(NGLLX,NGLLY,nabs_zmin_oc))
+
+ ! read arrays for Stacey conditions
+ call read_mesh_databases_stacey(myrank, &
+ nimin_crust_mantle,nimax_crust_mantle,njmin_crust_mantle, &
+ njmax_crust_mantle,nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nimin_outer_core,nimax_outer_core,njmin_outer_core, &
+ njmax_outer_core,nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ reclen_zmin,NSPEC2D_BOTTOM, &
+ SIMULATION_TYPE,SAVE_FORWARD,LOCAL_PATH,NSTEP)
+
+ endif
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+! source and receivers
+
+ ! 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(tshift_cmt(NSOURCES))
+ allocate(hdur(NSOURCES))
+ allocate(hdur_gaussian(NSOURCES))
+ allocate(theta_source(NSOURCES))
+ allocate(phi_source(NSOURCES))
+ allocate(nu_source(NDIM,NDIM,NSOURCES))
+
+ ! 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(stbur(nrec))
+ allocate(nu(NDIM,NDIM,nrec))
+
+ ! locates sources and receivers
+ call setup_sources_receivers(NSOURCES,myrank,ibool_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xigll,yigll,zigll,TOPOGRAPHY, &
+ sec,tshift_cmt,theta_source,phi_source, &
+ NSTEP,DT,hdur,hdur_gaussian,t0,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, &
+ rec_filename,nrec,islice_selected_rec,ispec_selected_rec, &
+ xi_receiver,eta_receiver,gamma_receiver,station_name,network_name, &
+ stlat,stlon,stele,stbur,nu, &
+ nrec_local,nadj_rec_local,nrec_simulation, &
+ SIMULATION_TYPE,RECEIVERS_CAN_BE_BURIED,MOVIE_SURFACE,MOVIE_VOLUME, &
+ HDUR_MOVIE,OUTPUT_FILES,LOCAL_PATH)
+
+ ! allocates source arrays
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ allocate(sourcearrays(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES))
+
+ ! stores source arrays
+ call setup_sources_receivers_srcarr(NSOURCES,myrank, &
+ ispec_selected_source,islice_selected_source, &
+ xi_source,eta_source,gamma_source, &
+ Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ 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,sourcearrays)
+ endif
+
+
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+ NSTEP_SUB_ADJ = ceiling( dble(NSTEP)/dble(NTSTEP_BETWEEN_READ_ADJSRC) )
+ allocate(iadj_vec(NSTEP))
+ ! initializes iadj_vec
+ do it=1,NSTEP
+ iadj_vec(it) = NSTEP-it+1 ! default is for reversing entire record
+ enddo
+
+ if(nadj_rec_local > 0) then
+ ! allocate adjoint source arrays
+ allocate(adj_sourcearrays(NDIM,NGLLX,NGLLY,NGLLZ,nadj_rec_local,NTSTEP_BETWEEN_READ_ADJSRC))
+ adj_sourcearrays = 0._CUSTOM_REAL
+
+ ! allocate indexing arrays
+ allocate(iadjsrc(NSTEP_SUB_ADJ,2))
+ allocate(iadjsrc_len(NSTEP_SUB_ADJ))
+ ! initializes iadjsrc, iadjsrc_len and iadj_vec
+ call setup_sources_receivers_adjindx(NSTEP,NSTEP_SUB_ADJ, &
+ NTSTEP_BETWEEN_READ_ADJSRC, &
+ iadjsrc,iadjsrc_len,iadj_vec)
+ endif
+ endif
+
+ ! allocates receiver interpolators
+ 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))
+ ! define and store Lagrange interpolators at all the receivers
+ if (SIMULATION_TYPE == 2) then
+ nadj_hprec_local = nrec_local
+ else
+ nadj_hprec_local = 1
+ endif
+ allocate(hpxir_store(nadj_hprec_local,NGLLX))
+ allocate(hpetar_store(nadj_hprec_local,NGLLY))
+ allocate(hpgammar_store(nadj_hprec_local,NGLLZ))
+
+ ! stores interpolators for receiver positions
+ call setup_sources_receivers_intp(NSOURCES,myrank, &
+ islice_selected_source, &
+ xi_source,eta_source,gamma_source, &
+ xigll,yigll,zigll, &
+ SIMULATION_TYPE,nrec,nrec_local, &
+ islice_selected_rec,number_receiver_global, &
+ xi_receiver,eta_receiver,gamma_receiver, &
+ hxir_store,hetar_store,hgammar_store, &
+ nadj_hprec_local,hpxir_store,hpetar_store,hpgammar_store)
+
+ ! allocate seismogram array
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ allocate(seismograms(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
+ if(ier /= 0) stop 'error while allocating seismograms'
+ else
+ allocate(seismograms(NDIM*NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
+ if(ier /= 0) stop 'error while allocating seismograms'
+ ! allocate Frechet derivatives array
+ allocate(moment_der(NDIM,NDIM,nrec_local),sloc_der(NDIM,nrec_local),stshift_der(nrec_local),shdur_der(nrec_local))
+ moment_der = 0._CUSTOM_REAL
+ sloc_der = 0._CUSTOM_REAL
+ stshift_der = 0._CUSTOM_REAL
+ shdur_der = 0._CUSTOM_REAL
+
+ endif
+ ! initialize seismograms
+ seismograms(:,:,:) = 0._CUSTOM_REAL
+ nit_written = 0
+ endif
+
+ ! get information about event name and location for SAC seismograms
+
+ ! The following line is added for get_event_info subroutine.
+ ! Because the way NSOURCES_SAC was declared has been changed.
+ ! The rest of the changes in this program is just the updates of the subroutines that
+ ! I did changes, e.g., adding/removing parameters. by Ebru Bozdag
+ call get_event_info_parallel(myrank,yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,&
+ event_name_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,mb_SAC,cmt_lat_SAC,&
+ cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,NSOURCES)
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+ ! user output
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ if(OCEANS_VAL) then
+ write(IMAIN,*) 'incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) 'no oceans'
+ endif
+
+ 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(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(ATTENUATION_VAL) then
+ write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
+
+ if(ATTENUATION_3D_VAL) write(IMAIN,*) 'using 3D attenuation'
+
+ if(USE_ATTENUATION_MIMIC ) write(IMAIN,*) 'mimicking effects on velocity only'
+ else
+ write(IMAIN,*) 'no attenuation'
+ endif
+
+ write(IMAIN,*)
+ write(IMAIN,*)
+ write(IMAIN,*)
+
+ endif
+
+ ! the mass matrix needs to be assembled with MPI here once and for all
+ call prepare_timerun_rmass(myrank,rmass_ocean_load,rmass_crust_mantle, &
+ rmass_outer_core,rmass_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_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, &
+ 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, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,npoin2D_max_all_CM_IC)
+
+ ! mass matrix including central cube
+ 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_VAL,NPROC_ETA_VAL,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(b_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(b_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))
+
+ ! handles the communications with the central cube if it was included in the mesh
+ call prepare_timerun_centralcube(myrank,rmass_inner_core, &
+ iproc_xi,iproc_eta,ichunk, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM, &
+ 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)
+
+ call fix_non_blocking_central_cube(is_on_a_slice_edge_inner_core, &
+ ibool_inner_core,NSPEC_INNER_CORE,NGLOB_INNER_CORE,nb_msgs_theor_in_cube,ibelm_bottom_inner_core, &
+ idoubling_inner_core,npoin2D_cube_from_slices,ibool_central_cube, &
+ NSPEC2D_BOTTOM(IREGION_INNER_CORE),ichunk)
+
+ else
+
+ ! allocate fictitious buffers for cube and slices with a dummy size
+ ! just to be able to use them as arguments in subroutine calls
+ allocate(sender_from_slices_to_cube(1))
+ allocate(buffer_all_cube_from_slices(1,1,1))
+ allocate(b_buffer_all_cube_from_slices(1,1,1))
+ allocate(buffer_slices(1,1))
+ allocate(b_buffer_slices(1,1))
+ allocate(buffer_slices2(1,1))
+ allocate(ibool_central_cube(1,1))
+
+ endif
+
+ ! check that all the mass matrices are positive
+ if(OCEANS_VAL) then
+ if(minval(rmass_ocean_load) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the oceans')
+ endif
+ if(minval(rmass_crust_mantle) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the crust_mantle')
+ if(minval(rmass_inner_core) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the inner core')
+ if(minval(rmass_outer_core) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the outer core')
+
+ ! for efficiency, invert final mass matrix once and for all on each slice
+ if(OCEANS_VAL) 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 i = 1,NGLOB_CRUST_MANTLE
+ call xyz_2_rthetaphi(xstore_crust_mantle(i), &
+ ystore_crust_mantle(i), &
+ zstore_crust_mantle(i),rval,thetaval,phival)
+ xstore_crust_mantle(i) = rval
+ ystore_crust_mantle(i) = thetaval
+ zstore_crust_mantle(i) = phival
+ enddo
+
+ ! convert in the outer core
+ do i = 1,NGLOB_OUTER_CORE
+ call xyz_2_rthetaphi(xstore_outer_core(i), &
+ ystore_outer_core(i), &
+ zstore_outer_core(i),rval,thetaval,phival)
+ xstore_outer_core(i) = rval
+ ystore_outer_core(i) = thetaval
+ zstore_outer_core(i) = phival
+ enddo
+
+ ! convert in the inner core
+ do i = 1,NGLOB_INNER_CORE
+ call xyz_2_rthetaphi(xstore_inner_core(i), &
+ ystore_inner_core(i), &
+ zstore_inner_core(i),rval,thetaval,phival)
+ xstore_inner_core(i) = rval
+ ystore_inner_core(i) = thetaval
+ zstore_inner_core(i) = phival
+ enddo
+
+ ! allocate files to save movies
+ if(MOVIE_SURFACE .or. NOISE_TOMOGRAPHY /=0) then ! for noise tomography, store_val_x/y/z/ux/uy/uz needed for 'surface movie'
+ if(MOVIE_COARSE .and. NOISE_TOMOGRAPHY ==0) then ! only output corners !for noise tomography, must NOT be coarse
+ nmovie_points = 2 * 2 * NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ if(NGLLX /= NGLLY) &
+ call exit_MPI(myrank,'MOVIE_COARSE together with MOVIE_SURFACE requires NGLLX=NGLLY')
+ NIT = NGLLX - 1
+ else
+ nmovie_points = NGLLX * NGLLY * NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ NIT = 1
+ endif
+ allocate(store_val_x(nmovie_points))
+ allocate(store_val_y(nmovie_points))
+ allocate(store_val_z(nmovie_points))
+ allocate(store_val_ux(nmovie_points))
+ allocate(store_val_uy(nmovie_points))
+ allocate(store_val_uz(nmovie_points))
+ if (MOVIE_SURFACE) then ! those arrays are not neccessary for noise tomography, so only allocate them in MOVIE_SURFACE case
+ allocate(store_val_x_all(nmovie_points,0:NPROCTOT_VAL-1))
+ allocate(store_val_y_all(nmovie_points,0:NPROCTOT_VAL-1))
+ allocate(store_val_z_all(nmovie_points,0:NPROCTOT_VAL-1))
+ allocate(store_val_ux_all(nmovie_points,0:NPROCTOT_VAL-1))
+ allocate(store_val_uy_all(nmovie_points,0:NPROCTOT_VAL-1))
+ allocate(store_val_uz_all(nmovie_points,0:NPROCTOT_VAL-1))
+ endif
+ endif
+
+
+ ! output point and element information for 3D movies
+ if(MOVIE_VOLUME) then
+ ! the following has to be true for the the array dimensions of eps to match with those of xstore etc..
+ ! note that epsilondev and eps_trace_over_3 don't have the same dimensions.. could cause trouble
+ if (NSPEC_CRUST_MANTLE_STR_OR_ATT /= NSPEC_CRUST_MANTLE) &
+ stop 'NSPEC_CRUST_MANTLE_STRAINS_ATT /= NSPEC_CRUST_MANTLE'
+ if (NSPEC_CRUST_MANTLE_STRAIN_ONLY /= NSPEC_CRUST_MANTLE) &
+ stop 'NSPEC_CRUST_MANTLE_STRAIN_ONLY /= NSPEC_CRUST_MANTLE'
+
+ write(prname,'(a,i6.6,a)') trim(LOCAL_PATH)//'/'//'proc',myrank,'_'
+ call count_points_movie_volume(prname,ibool_crust_mantle, xstore_crust_mantle,ystore_crust_mantle, &
+ zstore_crust_mantle,MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ MOVIE_COARSE,npoints_3dmovie,nspecel_3dmovie,num_ibool_3dmovie,mask_ibool,mask_3dmovie)
+
+
+ allocate(nu_3dmovie(3,3,npoints_3dmovie))
+
+ call write_movie_volume_mesh(npoints_3dmovie,prname,ibool_crust_mantle,xstore_crust_mantle, &
+ ystore_crust_mantle,zstore_crust_mantle, muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,mask_ibool,num_ibool_3dmovie,nu_3dmovie,MOVIE_COARSE)
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'Writing to movie3D files on local disk'
+ write(IMAIN,*) 'depth(T,B):',MOVIE_TOP,MOVIE_BOTTOM
+ write(IMAIN,*) 'lon(W,E) :',MOVIE_WEST,MOVIE_EAST
+ write(IMAIN,*) 'lat(S,N) :',MOVIE_SOUTH,MOVIE_NORTH
+ write(IMAIN,*) 'Starting at time step:',MOVIE_START, 'ending at:',MOVIE_STOP,'every: ',NTSTEP_BETWEEN_FRAMES
+ endif
+
+ endif ! MOVIE_VOLUME
+
+ ! sets up time increments and rotation constants
+ call prepare_timerun_constants(myrank,NSTEP, &
+ DT,t0,scale_t,scale_t_inv,scale_displ,scale_veloc, &
+ deltat,deltatover2,deltatsqover2, &
+ b_deltat,b_deltatover2,b_deltatsqover2, &
+ two_omega_earth,A_array_rotation,B_array_rotation, &
+ b_two_omega_earth, SIMULATION_TYPE)
+
+ ! precomputes gravity factors
+ call prepare_timerun_gravity(myrank, &
+ minus_g_cmb,minus_g_icb, &
+ minus_gravity_table,minus_deriv_gravity_table, &
+ density_table,d_ln_density_dr_table,minus_rho_g_over_kappa_fluid, &
+ ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ ! precomputes attenuation factors
+ if(ATTENUATION_VAL) then
+ call prepare_timerun_attenuation(myrank, &
+ factor_scale_crust_mantle,one_minus_sum_beta_crust_mantle,factor_common_crust_mantle, &
+ factor_scale_inner_core,one_minus_sum_beta_inner_core,factor_common_inner_core, &
+ 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, &
+ muvstore_crust_mantle,muhstore_crust_mantle,idoubling_crust_mantle, &
+ muvstore_inner_core, &
+ SIMULATION_TYPE,MOVIE_VOLUME,muvstore_crust_mantle_3dmovie, &
+ c11store_inner_core,c12store_inner_core,c13store_inner_core, &
+ c33store_inner_core,c44store_inner_core, &
+ alphaval,betaval,gammaval,b_alphaval,b_betaval,b_gammaval, &
+ deltat,b_deltat,LOCAL_PATH)
+ endif
+
+ if(myrank == 0) then
+
+ write(IMAIN,*) 'for overlapping of communications with calculations:'
+ write(IMAIN,*)
+
+ percentage_edge = 100.*count(is_on_a_slice_edge_crust_mantle(:))/real(NSPEC_CRUST_MANTLE)
+ write(IMAIN,*) 'percentage of edge elements in crust/mantle ',percentage_edge,'%'
+ write(IMAIN,*) 'percentage of volume elements in crust/mantle ',100. - percentage_edge,'%'
+ write(IMAIN,*)
+
+ percentage_edge = 100.*count(is_on_a_slice_edge_outer_core(:))/real(NSPEC_OUTER_CORE)
+ write(IMAIN,*) 'percentage of edge elements in outer core ',percentage_edge,'%'
+ write(IMAIN,*) 'percentage of volume elements in outer core ',100. - percentage_edge,'%'
+ write(IMAIN,*)
+
+ percentage_edge = 100.*count(is_on_a_slice_edge_inner_core(:))/real(NSPEC_INNER_CORE)
+ write(IMAIN,*) 'percentage of edge elements in inner core ',percentage_edge,'%'
+ write(IMAIN,*) 'percentage of volume elements in inner core ',100. - percentage_edge,'%'
+ write(IMAIN,*)
+
+ endif
+
+ if(.not. USE_NONBLOCKING_COMMS) then
+ is_on_a_slice_edge_crust_mantle(:) = .true.
+ is_on_a_slice_edge_outer_core(:) = .true.
+ is_on_a_slice_edge_inner_core(:) = .true.
+ 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
+
+ if (SIMULATION_TYPE == 3) then
+ rho_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
+ beta_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
+ alpha_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
+ if (NOISE_TOMOGRAPHY == 3) Sigma_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
+
+ ! approximate hessian
+ if( APPROXIMATE_HESS_KL ) then
+ allocate( hess_kl_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT))
+ hess_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
+ endif
+
+ ! For anisotropic kernels (in crust_mantle only)
+ cijkl_kl_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
+
+ rho_kl_outer_core(:,:,:,:) = 0._CUSTOM_REAL
+ alpha_kl_outer_core(:,:,:,:) = 0._CUSTOM_REAL
+ beta_kl_outer_core(:,:,:,:) = 0._CUSTOM_REAL
+
+ rho_kl_inner_core(:,:,:,:) = 0._CUSTOM_REAL
+ beta_kl_inner_core(:,:,:,:) = 0._CUSTOM_REAL
+ alpha_kl_inner_core(:,:,:,:) = 0._CUSTOM_REAL
+
+ div_displ_outer_core(:,:,:,:) = 0._CUSTOM_REAL
+ b_div_displ_outer_core(:,:,:,:) = 0._CUSTOM_REAL
+
+ ! deviatoric kernel check
+ if( deviatoric_outercore) then
+ nspec_beta_kl_outer_core = NSPEC_OUTER_CORE_ADJOINT
+ else
+ nspec_beta_kl_outer_core = 1
+ endif
+ allocate(beta_kl_outer_core(NGLLX,NGLLY,NGLLZ,nspec_beta_kl_outer_core))
+ beta_kl_outer_core = 0._CUSTOM_REAL
+ endif
+
+ ! initialize to be on the save side for adjoint runs SIMULATION_TYPE==2
+ eps_trace_over_3_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
+ epsilondev_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
+ eps_trace_over_3_inner_core(:,:,:,:) = 0._CUSTOM_REAL
+ epsilondev_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
+ if(FIX_UNDERFLOW_PROBLEM) then
+ eps_trace_over_3_crust_mantle(:,:,:,:) = VERYSMALLVAL
+ epsilondev_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
+ eps_trace_over_3_inner_core(:,:,:,:) = VERYSMALLVAL
+ epsilondev_inner_core(:,:,:,:,:) = VERYSMALLVAL
+ endif
+
+ if (COMPUTE_AND_STORE_STRAIN) then
+ if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3)) then
+ Iepsilondev_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
+ Ieps_trace_over_3_crust_mantle(:,:,:,:)=0._CUSTOM_REAL
+ endif
+ endif
+
+ ! clear memory variables if attenuation
+ if(ATTENUATION_VAL) then
+ 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
+
+ ! reads files back from local disk or MT tape system if restart file
+ ! note: for SIMULATION_TYPE 3 simulations, the stored wavefields
+ ! will be read in the time loop after the Newmark time scheme update.
+ ! this makes indexing and timing easier to match with adjoint wavefields indexing.
+ call read_forward_arrays_startrun(myrank,NSTEP, &
+ SIMULATION_TYPE,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
+ it_begin,it_end, &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
+ displ_inner_core,veloc_inner_core,accel_inner_core, &
+ displ_outer_core,veloc_outer_core,accel_outer_core, &
+ R_memory_crust_mantle,R_memory_inner_core, &
+ epsilondev_crust_mantle,epsilondev_inner_core, &
+ A_array_rotation,B_array_rotation, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+ b_R_memory_crust_mantle,b_R_memory_inner_core, &
+ b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+
+!<YANGL
+ ! NOISE TOMOGRAPHY
+ if ( NOISE_TOMOGRAPHY /= 0 ) then
+ allocate(noise_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NSTEP))
+ allocate(normal_x_noise(nmovie_points))
+ allocate(normal_y_noise(nmovie_points))
+ allocate(normal_z_noise(nmovie_points))
+ allocate(mask_noise(nmovie_points))
+ noise_sourcearray(:,:,:,:,:) = 0._CUSTOM_REAL
+ normal_x_noise(:) = 0._CUSTOM_REAL
+ normal_y_noise(:) = 0._CUSTOM_REAL
+ normal_z_noise(:) = 0._CUSTOM_REAL
+ mask_noise(:) = 0._CUSTOM_REAL
+
+ call read_parameters_noise(myrank,nrec,NSTEP,nmovie_points, &
+ islice_selected_rec,xi_receiver,eta_receiver,gamma_receiver,nu, &
+ noise_sourcearray,xigll,yigll,zigll,NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ NIT, ibool_crust_mantle, ibelm_top_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ irec_master_noise,normal_x_noise,normal_y_noise,normal_z_noise,mask_noise)
+
+ if (myrank == 0) &
+ call check_parameters_noise(myrank,NOISE_TOMOGRAPHY,SIMULATION_TYPE,SAVE_FORWARD, &
+ NUMBER_OF_RUNS, NUMBER_OF_THIS_RUN,ROTATE_SEISMOGRAMS_RT, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE, USE_BINARY_FOR_LARGE_FILE, &
+ MOVIE_COARSE)
+ endif
+!>YANGL
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+!
+! s t a r t t i m e i t e r a t i o n s
+!
+
+! synchronize all processes to make sure everybody is ready to start time loop
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+ if(myrank == 0) write(IMAIN,*) 'All processes are synchronized before time loop'
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Starting time iteration loop...'
+ write(IMAIN,*)
+ endif
+
+! create an empty file to monitor the start of the simulation
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/starttimeloop.txt',status='unknown',action='write')
+ write(IOUT,*) 'hello, starting time loop'
+ close(IOUT)
+ endif
+
+! initialize variables for writing seismograms
+ seismo_offset = it_begin-1
+ seismo_current = 0
+
+ imodulo_NGLOB_CRUST_MANTLE = mod(NGLOB_CRUST_MANTLE,3)
+
+! get MPI starting time
+ time_start = MPI_WTIME()
+
+! *********************************************************
+! ************* MAIN LOOP OVER THE TIME STEPS *************
+! *********************************************************
+
+ do it = it_begin,it_end
+
+ ! update position in seismograms
+ seismo_current = seismo_current + 1
+
+! way 1:
+! ! mantle
+! do i=1,NGLOB_CRUST_MANTLE
+! displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
+! + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
+! veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
+! + deltatover2*accel_crust_mantle(:,i)
+! 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
+
+! way 2:
+! One common technique in computational science to help enhance pipelining is loop unrolling
+!
+! we're accessing NDIM=3 components at each line,
+! that is, for an iteration, the register must contain
+! NDIM * displ_ + NDIM * veloc_ + NDIM * accel + deltat + deltatsq..
+! in most cases a real (CUSTOM_REAL) value will have 4 bytes,
+! assuming a default cache size of about 128 bytes, we unroll here in steps of 3, thus 29 reals or 118 bytes,
+! rather than with steps of 4
+ if(imodulo_NGLOB_CRUST_MANTLE >= 1) then
+ do i = 1,imodulo_NGLOB_CRUST_MANTLE
+ displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
+ + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
+
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
+ + deltatover2*accel_crust_mantle(:,i)
+
+ accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ endif
+
+ do i = mod(NGLOB_CRUST_MANTLE,3)+1,NGLOB_CRUST_MANTLE, 3 ! in steps of 3
+ displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
+ + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
+ displ_crust_mantle(:,i+1) = displ_crust_mantle(:,i+1) &
+ + deltat*veloc_crust_mantle(:,i+1) + deltatsqover2*accel_crust_mantle(:,i+1)
+ displ_crust_mantle(:,i+2) = displ_crust_mantle(:,i+2) &
+ + deltat*veloc_crust_mantle(:,i+2) + deltatsqover2*accel_crust_mantle(:,i+2)
+
+
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
+ + deltatover2*accel_crust_mantle(:,i)
+ veloc_crust_mantle(:,i+1) = veloc_crust_mantle(:,i+1) &
+ + deltatover2*accel_crust_mantle(:,i+1)
+ veloc_crust_mantle(:,i+2) = veloc_crust_mantle(:,i+2) &
+ + deltatover2*accel_crust_mantle(:,i+2)
+
+ ! set acceleration to zero
+ ! note: we do initialize acceleration in this loop since it is read already into the cache,
+ ! otherwise it would have to be read in again for this explicitly,
+ ! which would make this step more expensive
+ accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ accel_crust_mantle(:,i+1) = 0._CUSTOM_REAL
+ accel_crust_mantle(:,i+2) = 0._CUSTOM_REAL
+ enddo
+
+
+ ! outer core
+ do i = 1,mod(NGLOB_OUTER_CORE,4)
+ displ_outer_core(i) = displ_outer_core(i) &
+ + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
+
+ veloc_outer_core(i) = veloc_outer_core(i) &
+ + deltatover2*accel_outer_core(i)
+
+ accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ do i = mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE, 4 ! in steps of 4
+ displ_outer_core(i) = displ_outer_core(i) &
+ + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
+ displ_outer_core(i+1) = displ_outer_core(i+1) &
+ + deltat*veloc_outer_core(i+1) + deltatsqover2*accel_outer_core(i+1)
+ displ_outer_core(i+2) = displ_outer_core(i+2) &
+ + deltat*veloc_outer_core(i+2) + deltatsqover2*accel_outer_core(i+2)
+ displ_outer_core(i+3) = displ_outer_core(i+3) &
+ + deltat*veloc_outer_core(i+3) + deltatsqover2*accel_outer_core(i+3)
+
+ veloc_outer_core(i) = veloc_outer_core(i) &
+ + deltatover2*accel_outer_core(i)
+ veloc_outer_core(i+1) = veloc_outer_core(i+1) &
+ + deltatover2*accel_outer_core(i+1)
+ veloc_outer_core(i+2) = veloc_outer_core(i+2) &
+ + deltatover2*accel_outer_core(i+2)
+ veloc_outer_core(i+3) = veloc_outer_core(i+3) &
+ + deltatover2*accel_outer_core(i+3)
+
+ accel_outer_core(i) = 0._CUSTOM_REAL
+ accel_outer_core(i+1) = 0._CUSTOM_REAL
+ accel_outer_core(i+2) = 0._CUSTOM_REAL
+ accel_outer_core(i+3) = 0._CUSTOM_REAL
+ enddo
+
+
+ ! inner core
+ do i = 1,mod(NGLOB_INNER_CORE,3)
+ displ_inner_core(:,i) = displ_inner_core(:,i) &
+ + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
+
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) &
+ + deltatover2*accel_inner_core(:,i)
+
+ accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+ do i = mod(NGLOB_INNER_CORE,3)+1,NGLOB_INNER_CORE, 3 ! in steps of 3
+ displ_inner_core(:,i) = displ_inner_core(:,i) &
+ + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
+ displ_inner_core(:,i+1) = displ_inner_core(:,i+1) &
+ + deltat*veloc_inner_core(:,i+1) + deltatsqover2*accel_inner_core(:,i+1)
+ displ_inner_core(:,i+2) = displ_inner_core(:,i+2) &
+ + deltat*veloc_inner_core(:,i+2) + deltatsqover2*accel_inner_core(:,i+2)
+
+
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) &
+ + deltatover2*accel_inner_core(:,i)
+ veloc_inner_core(:,i+1) = veloc_inner_core(:,i+1) &
+ + deltatover2*accel_inner_core(:,i+1)
+ veloc_inner_core(:,i+2) = veloc_inner_core(:,i+2) &
+ + deltatover2*accel_inner_core(:,i+2)
+
+ accel_inner_core(:,i) = 0._CUSTOM_REAL
+ accel_inner_core(:,i+1) = 0._CUSTOM_REAL
+ accel_inner_core(:,i+2) = 0._CUSTOM_REAL
+ enddo
+
+
+
+ ! backward field
+ if (SIMULATION_TYPE == 3) then
+! way 1:
+! do i=1,NGLOB_CRUST_MANTLE
+! b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+! + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
+! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
+! + b_deltatover2*b_accel_crust_mantle(:,i)
+! enddo
+! do i=1,NGLOB_OUTER_CORE
+! b_displ_outer_core(i) = b_displ_outer_core(i) &
+! + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
+! b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+! + b_deltatover2*b_accel_outer_core(i)
+! enddo
+! do i=1,NGLOB_INNER_CORE
+! b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
+! + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
+! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
+! + b_deltatover2*b_accel_inner_core(:,i)
+! enddo
+
+! way 2:
+ if(imodulo_NGLOB_CRUST_MANTLE >= 1) then
+ do i=1,imodulo_NGLOB_CRUST_MANTLE
+ b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+ + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
+ + b_deltatover2*b_accel_crust_mantle(:,i)
+ b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ endif
+
+ do i=mod(NGLOB_CRUST_MANTLE,3)+1,NGLOB_CRUST_MANTLE,3
+ b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+ + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
+ b_displ_crust_mantle(:,i+1) = b_displ_crust_mantle(:,i+1) &
+ + b_deltat*b_veloc_crust_mantle(:,i+1) + b_deltatsqover2*b_accel_crust_mantle(:,i+1)
+ b_displ_crust_mantle(:,i+2) = b_displ_crust_mantle(:,i+2) &
+ + b_deltat*b_veloc_crust_mantle(:,i+2) + b_deltatsqover2*b_accel_crust_mantle(:,i+2)
+
+
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
+ + b_deltatover2*b_accel_crust_mantle(:,i)
+ b_veloc_crust_mantle(:,i+1) = b_veloc_crust_mantle(:,i+1) &
+ + b_deltatover2*b_accel_crust_mantle(:,i+1)
+ b_veloc_crust_mantle(:,i+2) = b_veloc_crust_mantle(:,i+2) &
+ + b_deltatover2*b_accel_crust_mantle(:,i+2)
+
+ b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ b_accel_crust_mantle(:,i+1) = 0._CUSTOM_REAL
+ b_accel_crust_mantle(:,i+2) = 0._CUSTOM_REAL
+ enddo
+
+
+ do i=1,mod(NGLOB_OUTER_CORE,4)
+ b_displ_outer_core(i) = b_displ_outer_core(i) &
+ + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+ + b_deltatover2*b_accel_outer_core(i)
+ b_accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ do i=mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE,4
+ b_displ_outer_core(i) = b_displ_outer_core(i) &
+ + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
+ b_displ_outer_core(i+1) = b_displ_outer_core(i+1) &
+ + b_deltat*b_veloc_outer_core(i+1) + b_deltatsqover2*b_accel_outer_core(i+1)
+ b_displ_outer_core(i+2) = b_displ_outer_core(i+2) &
+ + b_deltat*b_veloc_outer_core(i+2) + b_deltatsqover2*b_accel_outer_core(i+2)
+ b_displ_outer_core(i+3) = b_displ_outer_core(i+3) &
+ + b_deltat*b_veloc_outer_core(i+3) + b_deltatsqover2*b_accel_outer_core(i+3)
+
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+ + b_deltatover2*b_accel_outer_core(i)
+ b_veloc_outer_core(i+1) = b_veloc_outer_core(i+1) &
+ + b_deltatover2*b_accel_outer_core(i+1)
+ b_veloc_outer_core(i+2) = b_veloc_outer_core(i+2) &
+ + b_deltatover2*b_accel_outer_core(i+2)
+ b_veloc_outer_core(i+3) = b_veloc_outer_core(i+3) &
+ + b_deltatover2*b_accel_outer_core(i+3)
+
+ b_accel_outer_core(i) = 0._CUSTOM_REAL
+ b_accel_outer_core(i+1) = 0._CUSTOM_REAL
+ b_accel_outer_core(i+2) = 0._CUSTOM_REAL
+ b_accel_outer_core(i+3) = 0._CUSTOM_REAL
+ enddo
+
+
+ do i=1,mod(NGLOB_INNER_CORE,3)
+ b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
+ + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
+ + b_deltatover2*b_accel_inner_core(:,i)
+ b_accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+ do i=mod(NGLOB_INNER_CORE,3)+1,NGLOB_INNER_CORE,3
+ b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
+ + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
+ b_displ_inner_core(:,i+1) = b_displ_inner_core(:,i+1) &
+ + b_deltat*b_veloc_inner_core(:,i+1) + b_deltatsqover2*b_accel_inner_core(:,i+1)
+ b_displ_inner_core(:,i+2) = b_displ_inner_core(:,i+2) &
+ + b_deltat*b_veloc_inner_core(:,i+2) + b_deltatsqover2*b_accel_inner_core(:,i+2)
+
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
+ + b_deltatover2*b_accel_inner_core(:,i)
+ b_veloc_inner_core(:,i+1) = b_veloc_inner_core(:,i+1) &
+ + b_deltatover2*b_accel_inner_core(:,i+1)
+ b_veloc_inner_core(:,i+2) = b_veloc_inner_core(:,i+2) &
+ + b_deltatover2*b_accel_inner_core(:,i+2)
+
+ b_accel_inner_core(:,i) = 0._CUSTOM_REAL
+ b_accel_inner_core(:,i+1) = 0._CUSTOM_REAL
+ b_accel_inner_core(:,i+2) = 0._CUSTOM_REAL
+ enddo
+
+ endif
+
+ ! integral of strain for adjoint movie volume
+ if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) ) then
+ Iepsilondev_crust_mantle(:,:,:,:,:) = Iepsilondev_crust_mantle(:,:,:,:,:) &
+ + deltat*epsilondev_crust_mantle(:,:,:,:,:)
+ Ieps_trace_over_3_crust_mantle(:,:,:,:) = Ieps_trace_over_3_crust_mantle(:,:,:,:) &
+ + deltat*eps_trace_over_3_crust_mantle(:,:,:,:)
+ endif
+
+ ! daniel: debugging
+ !if( maxval(displ_crust_mantle(1,:)**2 + &
+ ! displ_crust_mantle(2,:)**2 + displ_crust_mantle(3,:)**2) > 1.e4 ) then
+ ! print*,'slice',myrank
+ ! print*,' crust_mantle displ:', maxval(displ_crust_mantle(1,:)), &
+ ! maxval(displ_crust_mantle(2,:)),maxval(displ_crust_mantle(3,:))
+ ! print*,' indxs: ',maxloc( displ_crust_mantle(1,:)),maxloc( displ_crust_mantle(2,:)),maxloc( displ_crust_mantle(3,:))
+ ! indx = maxloc( displ_crust_mantle(3,:) )
+ ! rval = xstore_crust_mantle(indx(1))
+ ! thetaval = ystore_crust_mantle(indx(1))
+ ! phival = zstore_crust_mantle(indx(1))
+ ! !thetaval = PI/2.0d0-datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dsin(dble(thetaval))))
+ ! print*,'r/lat/lon:',rval*R_EARTH_KM,90.0-thetaval*180./PI,phival*180./PI
+ ! call rthetaphi_2_xyz(rval,thetaval,phival,xstore_crust_mantle(indx(1)),&
+ ! ystore_crust_mantle(indx(1)),zstore_crust_mantle(indx(1)))
+ ! print*,'x/y/z:',rval,thetaval,phival
+ ! call exit_MPI(myrank,'error stability')
+ !endif
+
+
+ ! 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) &
+ call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
+ b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
+ eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ myrank)
+
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the fluid
+ ! ****************************************************
+
+ ! compute internal forces in the fluid region
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
+ else
+ time = (dble(it-1)*DT-t0)*scale_t_inv
+ endif
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ if (SIMULATION_TYPE == 3) then
+ ! note on backward/reconstructed wavefields:
+ ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
+ ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
+ ! to a time (NSTEP - (it-1) - 1)*DT - t0
+ ! for reconstructing the rotational contributions
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
+ else
+ time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
+ endif
+
+ b_iphase = 0 ! do not start any non blocking communications at this stage
+ b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+ endif
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
+ NSTEP,it,ibool_outer_core, &
+ veloc_outer_core,accel_outer_core,b_accel_outer_core, &
+ vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+ jacobian2D_bottom_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+ endif ! Stacey conditions
+
+
+ ! ****************************************************
+ ! ********** add matching with solid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the fluid
+
+ !---
+ !--- couple with mantle at the top of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) &
+ call compute_coupling_fluid_CMB(displ_crust_mantle,b_displ_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core,b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ SIMULATION_TYPE,NSPEC2D_TOP(IREGION_OUTER_CORE))
+
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) &
+ call compute_coupling_fluid_ICB(displ_inner_core,b_displ_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ accel_outer_core,b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
+
+
+ ! assemble all the contributions between slices using MPI
+
+ ! outer core
+ if(USE_NONBLOCKING_COMMS) then
+ iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY,NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY,NCHUNKS_VAL,iphase)
+ enddo
+
+ else ! if(.not. USE_NONBLOCKING_COMMS) then
+
+ call assemble_MPI_scalar_block(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_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY,NCHUNKS_VAL)
+
+ endif
+
+ ! multiply by the inverse of the mass matrix and update velocity
+
+! way 1:
+! 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
+
+! way 2:
+ do i=1,mod(NGLOB_OUTER_CORE,4)
+ 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
+ do i=mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE,4
+ accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
+ accel_outer_core(i+1) = accel_outer_core(i+1)*rmass_outer_core(i+1)
+ accel_outer_core(i+2) = accel_outer_core(i+2)*rmass_outer_core(i+2)
+ accel_outer_core(i+3) = accel_outer_core(i+3)*rmass_outer_core(i+3)
+
+ veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
+ veloc_outer_core(i+1) = veloc_outer_core(i+1) + deltatover2*accel_outer_core(i+1)
+ veloc_outer_core(i+2) = veloc_outer_core(i+2) + deltatover2*accel_outer_core(i+2)
+ veloc_outer_core(i+3) = veloc_outer_core(i+3) + deltatover2*accel_outer_core(i+3)
+ enddo
+
+ if (SIMULATION_TYPE == 3) then
+
+! ------------------- new non blocking implementation -------------------
+
+ ! outer core
+ if(USE_NONBLOCKING_COMMS) then
+ b_iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY,NCHUNKS_VAL,b_iphase)
+
+ b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,b_accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY,NCHUNKS_VAL,b_iphase)
+ enddo
+
+ else ! if(.not. USE_NONBLOCKING_COMMS) then
+
+ call assemble_MPI_scalar_block(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core, &
+ iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY,NCHUNKS_VAL)
+
+ endif
+
+! ------------------- new non blocking implementation -------------------
+
+! way 1:
+! do i=1,NGLOB_OUTER_CORE
+! b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
+! b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
+! enddo
+
+! way 2:
+ do i=1,mod(NGLOB_OUTER_CORE,4)
+ b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
+ enddo
+ do i=mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE,4
+ b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
+ b_accel_outer_core(i+1) = b_accel_outer_core(i+1)*rmass_outer_core(i+1)
+ b_accel_outer_core(i+2) = b_accel_outer_core(i+2)*rmass_outer_core(i+2)
+ b_accel_outer_core(i+3) = b_accel_outer_core(i+3)*rmass_outer_core(i+3)
+
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
+ b_veloc_outer_core(i+1) = b_veloc_outer_core(i+1) + b_deltatover2*b_accel_outer_core(i+1)
+ b_veloc_outer_core(i+2) = b_veloc_outer_core(i+2) + b_deltatover2*b_accel_outer_core(i+2)
+ b_veloc_outer_core(i+3) = b_veloc_outer_core(i+3) + b_deltatover2*b_accel_outer_core(i+3)
+ enddo
+
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the solid
+ ! ****************************************************
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ iphase_CC = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+!----------------------
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+!----------------------
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+ if (SIMULATION_TYPE == 3 ) then
+
+ b_iphase = 0 ! do not start any non blocking communications at this stage
+ b_iphase_CC = 0 ! do not start any non blocking communications at this stage
+ b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+!----------------------
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+!----------------------
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+!----------------------
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+!----------------------
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle, &
+ b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
+ b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+
+ endif
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+!----------------------
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+!----------------------
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+ if (SIMULATION_TYPE == 3) then
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+!----------------------
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+!----------------------
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+!----------------------
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+!----------------------
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+ endif
+
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ call compute_stacey_crust_mantle(ichunk,SIMULATION_TYPE, &
+ NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
+ veloc_crust_mantle,accel_crust_mantle,b_accel_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+ wgllwgll_xz,wgllwgll_yz, &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+ normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+ rho_vp_crust_mantle,rho_vs_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+ ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ nimin_crust_mantle,nimax_crust_mantle, &
+ njmin_crust_mantle,njmax_crust_mantle, &
+ nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+ endif ! Stacey conditions
+
+ ! add the sources
+ if (SIMULATION_TYPE == 1) &
+ call compute_add_sources(myrank,NSOURCES, &
+ accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ ! add adjoint sources
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+ if( nadj_rec_local > 0 ) &
+ call compute_add_sources_adjoint(myrank,nrec, &
+ nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
+ accel_crust_mantle,adj_sourcearrays, &
+ nu,xi_receiver,eta_receiver,gamma_receiver, &
+ xigll,yigll,zigll,ibool_crust_mantle, &
+ islice_selected_rec,ispec_selected_rec, &
+ NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
+ it,it_begin,station_name,network_name,DT)
+ endif
+
+ ! add sources for backward/reconstructed wavefield
+ if (SIMULATION_TYPE == 3) &
+ call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+ b_accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+
+!<YANGL
+ ! NOISE_TOMOGRAPHY
+ if ( NOISE_TOMOGRAPHY == 1 ) then
+ ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
+ ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
+ ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
+ ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
+ call add_source_master_rec_noise(myrank,nrec, &
+ NSTEP,accel_crust_mantle,noise_sourcearray, &
+ ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
+ it,irec_master_noise)
+ elseif ( NOISE_TOMOGRAPHY == 2 ) then
+ ! second step of noise tomography, i.e., read the surface movie saved at every timestep
+ ! use the movie to drive the ensemble forward wavefield
+ call noise_read_add_surface_movie(myrank,nmovie_points,accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ ibelm_top_crust_mantle,ibool_crust_mantle,NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ NIT,NSTEP-it+1,LOCAL_PATH,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
+ ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
+ ! note the ensemble forward sources are generally distributed on the surface of the earth
+ ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
+ ! therefore, we must add it here, before applying the inverse of mass matrix
+ elseif ( NOISE_TOMOGRAPHY == 3 ) then
+ ! third step of noise tomography, i.e., read the surface movie saved at every timestep
+ ! use the movie to reconstruct the ensemble forward wavefield
+ ! the ensemble adjoint wavefield is done as usual
+ ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
+ call noise_read_add_surface_movie(myrank,nmovie_points,b_accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ ibelm_top_crust_mantle,ibool_crust_mantle,NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ NIT,it,LOCAL_PATH,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ endif
+!>YANGL
+
+ ! ****************************************************
+ ! ********** add matching with fluid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the solid
+
+ !---
+ !--- couple with outer core at the bottom of the mantle
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) &
+ call compute_coupling_CMB_fluid(displ_crust_mantle,b_displ_crust_mantle, &
+ accel_crust_mantle,b_accel_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core,b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ RHO_TOP_OC,minus_g_cmb, &
+ SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) &
+ call compute_coupling_ICB_fluid(displ_inner_core,b_displ_inner_core, &
+ accel_inner_core,b_accel_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ accel_outer_core,b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ RHO_BOTTOM_OC,minus_g_icb, &
+ SIMULATION_TYPE,NSPEC2D_TOP(IREGION_INNER_CORE))
+
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ if(USE_NONBLOCKING_COMMS) then
+
+ iphase = 1 ! initialize the non blocking communication counter
+ iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+!----------------------
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+!----------------------
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+!----------------------
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+!----------------------
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+!----------------------
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+ enddo
+ else
+ ! 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_block(myrank, &
+ accel_crust_mantle,NGLOB_CRUST_MANTLE, &
+ accel_inner_core,NGLOB_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,buffer_received_faces, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL, &
+ NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
+ NGLOB2DMAX_XY,NCHUNKS_VAL)
+ endif
+
+ !---
+ !--- use buffers to assemble forces with the central cube
+ !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ if(USE_NONBLOCKING_COMMS) then
+ do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),accel_inner_core,NDIM,iphase_CC)
+ enddo
+ else
+ call assemble_MPI_central_cube_block(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
+ endif ! end of assembling forces with the central cube
+
+! way 1:
+! do i=1,NGLOB_CRUST_MANTLE
+! accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
+! + two_omega_earth*veloc_crust_mantle(2,i)
+! accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
+! - two_omega_earth*veloc_crust_mantle(1,i)
+! accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmass_crust_mantle(i)
+! enddo
+
+! way 2:
+ do i=1,mod(NGLOB_CRUST_MANTLE,4)
+ accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
+ + two_omega_earth*veloc_crust_mantle(2,i)
+ accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
+ - two_omega_earth*veloc_crust_mantle(1,i)
+ accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmass_crust_mantle(i)
+ enddo
+ do i=mod(NGLOB_CRUST_MANTLE,4)+1,NGLOB_CRUST_MANTLE,4
+ accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
+ + two_omega_earth*veloc_crust_mantle(2,i)
+ accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
+ - two_omega_earth*veloc_crust_mantle(1,i)
+ accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmass_crust_mantle(i)
+
+ accel_crust_mantle(1,i+1) = accel_crust_mantle(1,i+1)*rmass_crust_mantle(i+1) &
+ + two_omega_earth*veloc_crust_mantle(2,i+1)
+ accel_crust_mantle(2,i+1) = accel_crust_mantle(2,i+1)*rmass_crust_mantle(i+1) &
+ - two_omega_earth*veloc_crust_mantle(1,i+1)
+ accel_crust_mantle(3,i+1) = accel_crust_mantle(3,i+1)*rmass_crust_mantle(i+1)
+
+ accel_crust_mantle(1,i+2) = accel_crust_mantle(1,i+2)*rmass_crust_mantle(i+2) &
+ + two_omega_earth*veloc_crust_mantle(2,i+2)
+ accel_crust_mantle(2,i+2) = accel_crust_mantle(2,i+2)*rmass_crust_mantle(i+2) &
+ - two_omega_earth*veloc_crust_mantle(1,i+2)
+ accel_crust_mantle(3,i+2) = accel_crust_mantle(3,i+2)*rmass_crust_mantle(i+2)
+
+ accel_crust_mantle(1,i+3) = accel_crust_mantle(1,i+3)*rmass_crust_mantle(i+3) &
+ + two_omega_earth*veloc_crust_mantle(2,i+3)
+ accel_crust_mantle(2,i+3) = accel_crust_mantle(2,i+3)*rmass_crust_mantle(i+3) &
+ - two_omega_earth*veloc_crust_mantle(1,i+3)
+ accel_crust_mantle(3,i+3) = accel_crust_mantle(3,i+3)*rmass_crust_mantle(i+3)
+ enddo
+
+ if (SIMULATION_TYPE == 3) then
+
+! ------------------- new non blocking implementation -------------------
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ if(USE_NONBLOCKING_COMMS) then
+
+ b_iphase = 1 ! initialize the non blocking communication counter
+ b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+
+ b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+!----------------------
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+!----------------------
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+!----------------------
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+!----------------------
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+!----------------------
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+!----------------------
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+!----------------------
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+!----------------------
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
+ one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+ enddo
+ else
+ ! 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_block(myrank, &
+ b_accel_crust_mantle,NGLOB_CRUST_MANTLE, &
+ b_accel_inner_core,NGLOB_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, &
+ b_buffer_send_faces,b_buffer_received_faces, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL, &
+ NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
+ NGLOB2DMAX_XY,NCHUNKS_VAL)
+ endif
+
+ !---
+ !--- use buffers to assemble forces with the central cube
+ !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ if(USE_NONBLOCKING_COMMS) then
+ do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
+ enddo
+ else
+ call assemble_MPI_central_cube_block(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_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,b_accel_inner_core,NDIM)
+ endif
+ endif ! end of assembling forces with the central cube
+
+! ------------------- new non blocking implementation -------------------
+
+! way 1:
+! do i=1,NGLOB_CRUST_MANTLE
+! b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
+! + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+! b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
+! - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+! b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmass_crust_mantle(i)
+! enddo
+
+! way 2:
+ do i=1,mod(NGLOB_CRUST_MANTLE,4)
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmass_crust_mantle(i)
+ enddo
+ do i=mod(NGLOB_CRUST_MANTLE,4)+1,NGLOB_CRUST_MANTLE,4
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmass_crust_mantle(i) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmass_crust_mantle(i) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmass_crust_mantle(i)
+
+ b_accel_crust_mantle(1,i+1) = b_accel_crust_mantle(1,i+1)*rmass_crust_mantle(i+1) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i+1)
+ b_accel_crust_mantle(2,i+1) = b_accel_crust_mantle(2,i+1)*rmass_crust_mantle(i+1) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i+1)
+ b_accel_crust_mantle(3,i+1) = b_accel_crust_mantle(3,i+1)*rmass_crust_mantle(i+1)
+
+ b_accel_crust_mantle(1,i+2) = b_accel_crust_mantle(1,i+2)*rmass_crust_mantle(i+2) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i+2)
+ b_accel_crust_mantle(2,i+2) = b_accel_crust_mantle(2,i+2)*rmass_crust_mantle(i+2) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i+2)
+ b_accel_crust_mantle(3,i+2) = b_accel_crust_mantle(3,i+2)*rmass_crust_mantle(i+2)
+
+ b_accel_crust_mantle(1,i+3) = b_accel_crust_mantle(1,i+3)*rmass_crust_mantle(i+3) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i+3)
+ b_accel_crust_mantle(2,i+3) = b_accel_crust_mantle(2,i+3)*rmass_crust_mantle(i+3) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i+3)
+ b_accel_crust_mantle(3,i+3) = b_accel_crust_mantle(3,i+3)*rmass_crust_mantle(i+3)
+ enddo
+
+ endif
+
+ ! couples ocean with crust mantle
+ if(OCEANS_VAL) &
+ call compute_coupling_ocean(accel_crust_mantle,b_accel_crust_mantle, &
+ rmass_crust_mantle,rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load, &
+ SIMULATION_TYPE,NSPEC2D_TOP(IREGION_CRUST_MANTLE))
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+! way 1:
+! 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) &
+! + two_omega_earth*veloc_inner_core(2,i)
+! accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
+! - two_omega_earth*veloc_inner_core(1,i)
+! accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
+!
+! veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
+! enddo
+
+! way 2:
+ do i=1,mod(NGLOB_CRUST_MANTLE,4)
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ enddo
+ do i=mod(NGLOB_CRUST_MANTLE,4)+1,NGLOB_CRUST_MANTLE,4
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ veloc_crust_mantle(:,i+1) = veloc_crust_mantle(:,i+1) + deltatover2*accel_crust_mantle(:,i+1)
+ veloc_crust_mantle(:,i+2) = veloc_crust_mantle(:,i+2) + deltatover2*accel_crust_mantle(:,i+2)
+ veloc_crust_mantle(:,i+3) = veloc_crust_mantle(:,i+3) + deltatover2*accel_crust_mantle(:,i+3)
+ enddo
+
+ do i=1,mod(NGLOB_INNER_CORE,3)
+ accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
+ + two_omega_earth*veloc_inner_core(2,i)
+ accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
+ - two_omega_earth*veloc_inner_core(1,i)
+ accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
+
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
+ enddo
+ do i=mod(NGLOB_INNER_CORE,3)+1,NGLOB_INNER_CORE,3
+ accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
+ + two_omega_earth*veloc_inner_core(2,i)
+ accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
+ - two_omega_earth*veloc_inner_core(1,i)
+ accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
+
+ accel_inner_core(1,i+1) = accel_inner_core(1,i+1)*rmass_inner_core(i+1) &
+ + two_omega_earth*veloc_inner_core(2,i+1)
+ accel_inner_core(2,i+1) = accel_inner_core(2,i+1)*rmass_inner_core(i+1) &
+ - two_omega_earth*veloc_inner_core(1,i+1)
+ accel_inner_core(3,i+1) = accel_inner_core(3,i+1)*rmass_inner_core(i+1)
+
+ accel_inner_core(1,i+2) = accel_inner_core(1,i+2)*rmass_inner_core(i+2) &
+ + two_omega_earth*veloc_inner_core(2,i+2)
+ accel_inner_core(2,i+2) = accel_inner_core(2,i+2)*rmass_inner_core(i+2) &
+ - two_omega_earth*veloc_inner_core(1,i+2)
+ accel_inner_core(3,i+2) = accel_inner_core(3,i+2)*rmass_inner_core(i+2)
+
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
+ veloc_inner_core(:,i+1) = veloc_inner_core(:,i+1) + deltatover2*accel_inner_core(:,i+1)
+ veloc_inner_core(:,i+2) = veloc_inner_core(:,i+2) + deltatover2*accel_inner_core(:,i+2)
+ enddo
+
+ if (SIMULATION_TYPE == 3) then
+! way 1:
+! do i=1,NGLOB_CRUST_MANTLE
+! b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
+! enddo
+!
+! do i=1,NGLOB_INNER_CORE
+! b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
+! + b_two_omega_earth*b_veloc_inner_core(2,i)
+! b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
+! - b_two_omega_earth*b_veloc_inner_core(1,i)
+! b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
+!
+! b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
+! enddo
+
+! way 2:
+ do i=1,mod(NGLOB_CRUST_MANTLE,4)
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
+ enddo
+ do i=mod(NGLOB_CRUST_MANTLE,4)+1,NGLOB_CRUST_MANTLE,4
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
+ b_veloc_crust_mantle(:,i+1) = b_veloc_crust_mantle(:,i+1) + b_deltatover2*b_accel_crust_mantle(:,i+1)
+ b_veloc_crust_mantle(:,i+2) = b_veloc_crust_mantle(:,i+2) + b_deltatover2*b_accel_crust_mantle(:,i+2)
+ b_veloc_crust_mantle(:,i+3) = b_veloc_crust_mantle(:,i+3) + b_deltatover2*b_accel_crust_mantle(:,i+3)
+ enddo
+
+ do i=1,mod(NGLOB_INNER_CORE,3)
+ b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
+ + b_two_omega_earth*b_veloc_inner_core(2,i)
+ b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
+ - b_two_omega_earth*b_veloc_inner_core(1,i)
+ b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
+
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
+ enddo
+ do i=mod(NGLOB_INNER_CORE,3)+1,NGLOB_INNER_CORE,3
+ b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
+ + b_two_omega_earth*b_veloc_inner_core(2,i)
+ b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
+ - b_two_omega_earth*b_veloc_inner_core(1,i)
+ b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
+
+ b_accel_inner_core(1,i+1) = b_accel_inner_core(1,i+1)*rmass_inner_core(i+1) &
+ + b_two_omega_earth*b_veloc_inner_core(2,i+1)
+ b_accel_inner_core(2,i+1) = b_accel_inner_core(2,i+1)*rmass_inner_core(i+1) &
+ - b_two_omega_earth*b_veloc_inner_core(1,i+1)
+ b_accel_inner_core(3,i+1) = b_accel_inner_core(3,i+1)*rmass_inner_core(i+1)
+
+ b_accel_inner_core(1,i+2) = b_accel_inner_core(1,i+2)*rmass_inner_core(i+2) &
+ + b_two_omega_earth*b_veloc_inner_core(2,i+2)
+ b_accel_inner_core(2,i+2) = b_accel_inner_core(2,i+2)*rmass_inner_core(i+2) &
+ - b_two_omega_earth*b_veloc_inner_core(1,i+2)
+ b_accel_inner_core(3,i+2) = b_accel_inner_core(3,i+2)*rmass_inner_core(i+2)
+
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
+ b_veloc_inner_core(:,i+1) = b_veloc_inner_core(:,i+1) + b_deltatover2*b_accel_inner_core(:,i+1)
+ b_veloc_inner_core(:,i+2) = b_veloc_inner_core(:,i+2) + b_deltatover2*b_accel_inner_core(:,i+2)
+ enddo
+
+ endif
+
+
+ ! restores last time snapshot saved for backward/reconstruction of wavefields
+ ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
+ ! and adjoint sources will become more complicated
+ ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
+ if( SIMULATION_TYPE == 3 .and. it == 1 ) then
+ call read_forward_arrays(myrank, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+ b_R_memory_crust_mantle,b_R_memory_inner_core, &
+ b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+ endif
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+ if (SIMULATION_TYPE == 1) then
+ call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ else if (SIMULATION_TYPE == 2) then
+ call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
+ eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ hxir_store,hetar_store,hgammar_store, &
+ hpxir_store,hpetar_store,hpgammar_store, &
+ tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ moment_der,sloc_der,stshift_der,shdur_der, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
+ ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
+ NSTEP,it,nit_written)
+
+ else if (SIMULATION_TYPE == 3) then
+ call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ endif
+ endif ! nrec_local
+
+ ! write the current or final seismograms
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ else
+ if( nrec_local > 0 ) &
+ call write_adj_seismograms(seismograms,number_receiver_global, &
+ nrec_local,it,nit_written,DT, &
+ NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_PATH)
+ nit_written = it
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+! kernel calculations
+ if (SIMULATION_TYPE == 3) then
+ ! crust mantle
+ call compute_kernels_crust_mantle(ibool_crust_mantle, &
+ rho_kl_crust_mantle,beta_kl_crust_mantle, &
+ alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
+ accel_crust_mantle,b_displ_crust_mantle, &
+ epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
+ eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
+ deltat)
+
+ ! outer core
+ call compute_kernels_outer_core(ibool_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ displ_outer_core,accel_outer_core, &
+ b_displ_outer_core,b_accel_outer_core, &
+ vector_accel_outer_core,vector_displ_outer_core, &
+ b_vector_displ_outer_core, &
+ div_displ_outer_core,b_div_displ_outer_core, &
+ rhostore_outer_core,kappavstore_outer_core, &
+ rho_kl_outer_core,alpha_kl_outer_core, &
+ deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
+ deltat)
+
+ ! inner core
+ call compute_kernels_inner_core(ibool_inner_core, &
+ rho_kl_inner_core,beta_kl_inner_core, &
+ alpha_kl_inner_core, &
+ accel_inner_core,b_displ_inner_core, &
+ epsilondev_inner_core,b_epsilondev_inner_core, &
+ eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
+ deltat)
+
+!<YANGL
+ ! NOISE TOMOGRAPHY --- source strength kernel
+ if (NOISE_TOMOGRAPHY == 3) &
+ call compute_kernels_strength_noise(myrank,ibool_crust_mantle, &
+ Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
+ nmovie_points,normal_x_noise,normal_y_noise,normal_z_noise, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),ibelm_top_crust_mantle,LOCAL_PATH)
+!>YANGL
+
+ ! --- boundary kernels ------
+ if (SAVE_BOUNDARY_MESH) then
+ fluid_solid_boundary = .false.
+ iregion_code = IREGION_CRUST_MANTLE
+
+ ! Moho
+ if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
+
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
+
+ moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
+ endif
+
+ ! 400
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
+
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
+
+ d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
+
+ ! 670
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
+
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
+
+ d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
+
+ ! CMB
+ fluid_solid_boundary = .true.
+ iregion_code = IREGION_CRUST_MANTLE
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,idoubling_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
+ cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
+
+ iregion_code = IREGION_OUTER_CORE
+ call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
+ b_vector_displ_outer_core,nspec_outer_core, &
+ iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,idoubling_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core,&
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ k_bot,ibelm_top_outer_core,normal_top_outer_core, &
+ cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
+
+ cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
+
+ ! ICB
+ fluid_solid_boundary = .true.
+ call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
+ b_vector_displ_outer_core,nspec_outer_core, &
+ iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,idoubling_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core,&
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
+ icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
+
+ iregion_code = IREGION_INNER_CORE
+ call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
+ b_displ_inner_core,nspec_inner_core,iregion_code, &
+ ystore_inner_core,zstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core,&
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
+ dummy_array,dummy_array,dummy_array, &
+ c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ c33store_inner_core,dummy_array,dummy_array, &
+ dummy_array,c44store_inner_core,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
+ icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
+
+ icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
+ endif
+
+ ! approximate hessian
+ if( APPROXIMATE_HESS_KL ) then
+ call compute_kernels_hessian(ibool_crust_mantle, &
+ hess_kl_crust_mantle,&
+ accel_crust_mantle,b_accel_crust_mantle, &
+ deltat)
+ endif
+
+ endif ! end computing kernels
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+!<YANGL
+ ! first step of noise tomography, i.e., save a surface movie at every time step
+ ! modified from the subroutine 'write_movie_surface'
+ if ( NOISE_TOMOGRAPHY == 1 ) then
+ call noise_save_surface_movie(myrank,nmovie_points,displ_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ NIT,it,LOCAL_PATH)
+ endif
+!>YANGL
+
+ ! save movie on surface
+ if( MOVIE_SURFACE ) then
+ if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ ! save velocity here to avoid static offset on displacement for movies
+ call write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_x_all,store_val_y_all,store_val_z_all, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ store_val_ux_all,store_val_uy_all,store_val_uz_all, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ NIT,it,OUTPUT_FILES)
+ endif
+ endif
+
+
+ ! save movie in full 3D mesh
+ if(MOVIE_VOLUME ) then
+ if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
+ .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
+
+ if (MOVIE_VOLUME_TYPE == 1) then ! output strains
+
+ call write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
+ muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
+ ! output the Time Integral of Strain, or \mu*TIS
+ call write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,Ieps_trace_over_3_crust_mantle,Iepsilondev_crust_mantle, &
+ muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 4) then ! output divergence and curl in whole volume
+
+ call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
+ div_displ_outer_core,eps_trace_over_3_inner_core,epsilondev_crust_mantle,&
+ epsilondev_inner_core)
+
+ else if (MOVIE_VOLUME_TYPE == 5) then !output displacement
+ scalingval = scale_displ
+ call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,displ_crust_mantle, &
+ scalingval,mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 6) then !output velocity
+ scalingval = scale_veloc
+ call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,veloc_crust_mantle, &
+ scalingval,mask_3dmovie,nu_3dmovie)
+
+ else
+
+ stop 'MOVIE_VOLUME_TYPE has to be 1,2,3,4'
+
+ endif ! MOVIE_VOLUME_TYPE
+ endif
+ endif ! MOVIE_VOLUME
+
+!---- end of time iteration loop
+!
+ enddo ! end of main time loop
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+ ! synchronize all processes, waits until all processes have written their seismograms
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error synchronize after time loop')
+
+ ! closes Stacey absorbing boundary snapshots
+ if( ABSORBING_CONDITIONS ) then
+ ! crust mantle
+ if (nspec2D_xmin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ call close_file_abs(0)
+ endif
+
+ if (nspec2D_xmax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ call close_file_abs(1)
+ endif
+
+ if (nspec2D_ymin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ call close_file_abs(2)
+ endif
+
+ if (nspec2D_ymax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ call close_file_abs(3)
+ endif
+
+ ! outer core
+ if (nspec2D_xmin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ call close_file_abs(4)
+ endif
+
+ if (nspec2D_xmax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ call close_file_abs(5)
+ endif
+
+ if (nspec2D_ymin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ call close_file_abs(6)
+ endif
+
+ if (nspec2D_ymax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ call close_file_abs(7)
+ endif
+
+ if (NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 .and. (SIMULATION_TYPE == 3 &
+ .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ call close_file_abs(8)
+ endif
+
+ endif
+
+ ! synchronize all processes
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error synchronize closing snapshots')
+
+ ! save files to local disk or tape system if restart file
+ call save_forward_arrays(myrank,SIMULATION_TYPE,SAVE_FORWARD, &
+ NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
+ displ_inner_core,veloc_inner_core,accel_inner_core, &
+ displ_outer_core,veloc_outer_core,accel_outer_core, &
+ R_memory_crust_mantle,R_memory_inner_core, &
+ epsilondev_crust_mantle,epsilondev_inner_core, &
+ A_array_rotation,B_array_rotation, &
+ LOCAL_PATH)
+
+ ! synchronize all processes
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error synchronize saving forward')
+
+ ! dump kernel arrays
+ if (SIMULATION_TYPE == 3) then
+ ! crust mantle
+ call save_kernels_crust_mantle(myrank,scale_t,scale_displ, &
+ cijkl_kl_crust_mantle,rho_kl_crust_mantle, &
+ alpha_kl_crust_mantle,beta_kl_crust_mantle, &
+ ystore_crust_mantle,zstore_crust_mantle, &
+ rhostore_crust_mantle,muvstore_crust_mantle, &
+ kappavstore_crust_mantle,ibool_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle, &
+ eta_anisostore_crust_mantle,idoubling_crust_mantle, &
+ LOCAL_PATH)
+
+!<YANGL
+ ! noise strength kernel
+ if (NOISE_TOMOGRAPHY == 3) then
+ call save_kernels_strength_noise(myrank,LOCAL_PATH,Sigma_kl_crust_mantle)
+ endif
+!>YANGL
+
+ ! outer core
+ call save_kernels_outer_core(myrank,scale_t,scale_displ, &
+ rho_kl_outer_core,alpha_kl_outer_core, &
+ rhostore_outer_core,kappavstore_outer_core, &
+ deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
+ LOCAL_PATH)
+
+ ! inner core
+ call save_kernels_inner_core(myrank,scale_t,scale_displ, &
+ rho_kl_inner_core,beta_kl_inner_core,alpha_kl_inner_core, &
+ rhostore_inner_core,muvstore_inner_core,kappavstore_inner_core, &
+ LOCAL_PATH)
+
+ ! boundary kernel
+ if (SAVE_BOUNDARY_MESH) then
+ call save_kernels_boundary_kl(myrank,scale_t,scale_displ, &
+ moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl, &
+ LOCAL_PATH,HONOR_1D_SPHERICAL_MOHO)
+ endif
+
+ ! approximate hessian
+ if( APPROXIMATE_HESS_KL ) then
+ call save_kernels_hessian(myrank,scale_t,scale_displ, &
+ hess_kl_crust_mantle,LOCAL_PATH)
+ endif
+ endif
+
+ ! save source derivatives for adjoint simulations
+ if (SIMULATION_TYPE == 2 .and. nrec_local > 0) then
+ call save_kernels_source_derivatives(nrec_local,NSOURCES,scale_displ,scale_t, &
+ nu_source,moment_der,sloc_der,stshift_der,shdur_der,number_receiver_global)
+ 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)
+ if( ier /= 0 ) call exit_mpi(myrank,'error synchronize finishing simulation')
+
+ ! stop all the MPI processes, and exit
+ call MPI_FINALIZE(ier)
+
+ end program xspecfem3D
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/spline_routines.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/spline_routines.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/spline_routines.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/spline_routines.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -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 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute 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/src/stretching_function.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/stretching_function.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/stretching_function.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/stretching_function.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,149 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine 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.
+!
+! stretch_tab array uses indices index_radius & index_layer :
+! stretch_tab( index_radius (1=top,2=bottom) , index_layer (1=first layer, 2=second layer,..) )
+
+ 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
+
+ ! initializes array
+ ! for example: 2 element layers (ner=2) for most probable resolutions (NEX < 1000) in the crust
+ ! then stretch_tab(2,1) = 0.5 = stretch_tab(2,2)
+ 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
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine stretching_function_regional(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.
+!
+! stretch_tab array uses indices index_radius & index_layer :
+! stretch_tab( index_radius (1=top,2=bottom) , index_layer (1=first layer, 2=second layer,..) )
+
+ 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
+!
+! ! initializes array
+! ! for example: 2 element layers (ner=2) for most probable resolutions (NEX < 1000) in the crust
+! ! then stretch_tab(2,1) = 0.5 = stretch_tab(2,2)
+! 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
+
+ if( ner /= 3 ) stop 'error regional stretching function: ner value'
+
+ stretch_tab(1,1) = r_top
+ stretch_tab(1,2) = 6356000.d0 ! 15km second layer top
+ stretch_tab(1,3) = 6336000.d0 ! 35km third layer top
+
+ stretch_tab(2,1) = 6356000.d0 ! bottom first layer
+ stretch_tab(2,2) = 6336000.d0 ! bottom second layer
+ stretch_tab(2,3) = r_bottom ! bottom third layer
+
+end subroutine stretching_function_regional
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_chunks_data.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_chunks_data.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_chunks_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_chunks_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,648 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create AVS or DX 2D data for the faces of the global chunks,
+! to be recombined in postprocessing
+ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, &
+ ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
+ npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ logical iboun(6,nspec),ELLIPTICITY,ISOTROPIC_3D_MANTLE
+
+ double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
+ R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to output global points only once
+ integer npointot
+ logical mask_ibool(npointot)
+
+! numbering of global AVS or DX points
+ integer num_ibool_AVS_DX(npointot)
+
+ integer ispec
+ integer i,j,k,np
+ integer, dimension(8) :: iglobval
+ integer npoin,numpoin,nspecface,ispecface
+
+ real(kind=CUSTOM_REAL) vmin,vmax
+
+ double precision r,rho,vp,vs,Qkappa,Qmu
+ double precision vpv,vph,vsv,vsh,eta_aniso
+ double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
+ real(kind=CUSTOM_REAL) dvp,dvs
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+! processor identification
+ character(len=150) prname
+
+ integer iregion_code
+
+
+! writing points
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='unknown')
+ open(unit=11,file=prname(1:len_trim(prname))//'AVS_DXpointschunks_stability.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+ nspecface = 0
+
+! mark global AVS or DX points
+ do ispec=1,nspec
+! only if on face
+ if(iboun(1,ispec) .or. iboun(2,ispec) .or. &
+ iboun(3,ispec) .or. iboun(4,ispec)) then
+ iglobval(1)=ibool(1,1,1,ispec)
+ iglobval(2)=ibool(NGLLX,1,1,ispec)
+ iglobval(3)=ibool(NGLLX,NGLLY,1,ispec)
+ iglobval(4)=ibool(1,NGLLY,1,ispec)
+ iglobval(5)=ibool(1,1,NGLLZ,ispec)
+ iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
+ iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
+
+! face xi = xi_min
+ if(iboun(1,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglobval(1)) = .true.
+ mask_ibool(iglobval(4)) = .true.
+ mask_ibool(iglobval(8)) = .true.
+ mask_ibool(iglobval(5)) = .true.
+ endif
+
+! face xi = xi_max
+ if(iboun(2,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglobval(2)) = .true.
+ mask_ibool(iglobval(3)) = .true.
+ mask_ibool(iglobval(7)) = .true.
+ mask_ibool(iglobval(6)) = .true.
+ endif
+
+! face eta = eta_min
+ if(iboun(3,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglobval(1)) = .true.
+ mask_ibool(iglobval(2)) = .true.
+ mask_ibool(iglobval(6)) = .true.
+ mask_ibool(iglobval(5)) = .true.
+ endif
+
+! face eta = eta_max
+ if(iboun(4,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglobval(4)) = .true.
+ mask_ibool(iglobval(3)) = .true.
+ mask_ibool(iglobval(7)) = .true.
+ mask_ibool(iglobval(8)) = .true.
+ endif
+
+ endif
+ enddo
+
+! count global number of AVS or DX points
+ npoin = count(mask_ibool(:))
+
+! number of points in AVS or DX file
+ write(10,*) npoin
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! output global AVS or DX points
+ numpoin = 0
+ do ispec=1,nspec
+! only if on face
+ if(iboun(1,ispec) .or. iboun(2,ispec) .or. &
+ iboun(3,ispec) .or. iboun(4,ispec)) then
+ iglobval(1)=ibool(1,1,1,ispec)
+ iglobval(2)=ibool(NGLLX,1,1,ispec)
+ iglobval(3)=ibool(NGLLX,NGLLY,1,ispec)
+ iglobval(4)=ibool(1,NGLLY,1,ispec)
+ iglobval(5)=ibool(1,1,NGLLZ,ispec)
+ iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
+ iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
+
+! face xi = xi_min
+ if(iboun(1,ispec)) then
+
+ if(.not. mask_ibool(iglobval(1))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(1)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
+ sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
+ vmax = sqrt((kappavstore(1,1,1,ispec)+4.*muvstore(1,1,1,ispec)/3.)/rhostore(1,1,1,ispec))
+ vmin = sqrt(muvstore(1,1,1,ispec)/rhostore(1,1,1,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(1,1,1,ispec)**2 + ystore(1,1,1,ispec)**2 + zstore(1,1,1,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(4))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(4)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
+ sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
+ vmax = sqrt((kappavstore(1,NGLLY,1,ispec)+4.*muvstore(1,NGLLY,1,ispec)/3.)/rhostore(1,NGLLY,1,ispec))
+ vmin = sqrt(muvstore(1,NGLLY,1,ispec)/rhostore(1,NGLLY,1,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(1,NGLLY,1,ispec)**2 + ystore(1,NGLLY,1,ispec)**2 + zstore(1,NGLLY,1,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(8))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(8)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
+ vmax = sqrt((kappavstore(1,NGLLY,NGLLZ,ispec)+4.*muvstore(1,NGLLY,NGLLZ,ispec)/3.)/rhostore(1,NGLLY,NGLLZ,ispec))
+ vmin = sqrt(muvstore(1,NGLLY,NGLLZ,ispec)/rhostore(1,NGLLY,NGLLZ,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(1,NGLLY,NGLLZ,ispec)**2 + ystore(1,NGLLY,NGLLZ,ispec)**2 + zstore(1,NGLLY,NGLLZ,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(5))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(5)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
+ sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
+ vmax = sqrt((kappavstore(1,1,NGLLZ,ispec)+4.*muvstore(1,1,NGLLZ,ispec)/3.)/rhostore(1,1,NGLLZ,ispec))
+ vmin = sqrt(muvstore(1,1,NGLLZ,ispec)/rhostore(1,1,NGLLZ,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(1,1,NGLLZ,ispec)**2 + ystore(1,1,NGLLZ,ispec)**2 + zstore(1,1,NGLLZ,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ mask_ibool(iglobval(1)) = .true.
+ mask_ibool(iglobval(4)) = .true.
+ mask_ibool(iglobval(8)) = .true.
+ mask_ibool(iglobval(5)) = .true.
+ endif
+
+! face xi = xi_max
+ if(iboun(2,ispec)) then
+
+ if(.not. mask_ibool(iglobval(2))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(2)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
+ sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
+ vmax = sqrt((kappavstore(NGLLX,1,1,ispec)+4.*muvstore(NGLLX,1,1,ispec)/3.)/rhostore(NGLLX,1,1,ispec))
+ vmin = sqrt(muvstore(NGLLX,1,1,ispec)/rhostore(NGLLX,1,1,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(NGLLX,1,1,ispec)**2 + ystore(NGLLX,1,1,ispec)**2 + zstore(NGLLX,1,1,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(3))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(3)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
+ vmax = sqrt((kappavstore(NGLLX,NGLLY,1,ispec)+4.*muvstore(NGLLX,NGLLY,1,ispec)/3.)/rhostore(NGLLX,NGLLY,1,ispec))
+ vmin = sqrt(muvstore(NGLLX,NGLLY,1,ispec)/rhostore(NGLLX,NGLLY,1,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(NGLLX,NGLLY,1,ispec)**2 + ystore(NGLLX,NGLLY,1,ispec)**2 + zstore(NGLLX,NGLLY,1,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(7))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(7)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
+ vmax = sqrt((kappavstore(NGLLX,NGLLY,NGLLZ,ispec)+4.*muvstore(NGLLX,NGLLY,NGLLZ,ispec)/3.)/rhostore(NGLLX,NGLLY,NGLLZ,ispec))
+ vmin = sqrt(muvstore(NGLLX,NGLLY,NGLLZ,ispec)/rhostore(NGLLX,NGLLY,NGLLZ,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(NGLLX,NGLLY,NGLLZ,ispec)**2 + ystore(NGLLX,NGLLY,NGLLZ,ispec)**2 + zstore(NGLLX,NGLLY,NGLLZ,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(6))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(6)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
+ vmax = sqrt((kappavstore(NGLLX,1,NGLLZ,ispec)+4.*muvstore(NGLLX,1,NGLLZ,ispec)/3.)/rhostore(NGLLX,1,NGLLZ,ispec))
+ vmin = sqrt(muvstore(NGLLX,1,NGLLZ,ispec)/rhostore(NGLLX,1,NGLLZ,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(NGLLX,1,NGLLZ,ispec)**2 + ystore(NGLLX,1,NGLLZ,ispec)**2 + zstore(NGLLX,1,NGLLZ,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ mask_ibool(iglobval(2)) = .true.
+ mask_ibool(iglobval(3)) = .true.
+ mask_ibool(iglobval(7)) = .true.
+ mask_ibool(iglobval(6)) = .true.
+ endif
+
+! face eta = eta_min
+ if(iboun(3,ispec)) then
+
+ if(.not. mask_ibool(iglobval(1))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(1)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
+ sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
+ vmax = sqrt((kappavstore(1,1,1,ispec)+4.*muvstore(1,1,1,ispec)/3.)/rhostore(1,1,1,ispec))
+ vmin = sqrt(muvstore(1,1,1,ispec)/rhostore(1,1,1,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(1,1,1,ispec)**2 + ystore(1,1,1,ispec)**2 + zstore(1,1,1,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(2))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(2)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
+ sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
+ vmax = sqrt((kappavstore(NGLLX,1,1,ispec)+4.*muvstore(NGLLX,1,1,ispec)/3.)/rhostore(NGLLX,1,1,ispec))
+ vmin = sqrt(muvstore(NGLLX,1,1,ispec)/rhostore(NGLLX,1,1,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(NGLLX,1,1,ispec)**2 + ystore(NGLLX,1,1,ispec)**2 + zstore(NGLLX,1,1,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(6))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(6)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
+ vmax = sqrt((kappavstore(NGLLX,1,NGLLZ,ispec)+4.*muvstore(NGLLX,1,NGLLZ,ispec)/3.)/rhostore(NGLLX,1,NGLLZ,ispec))
+ vmin = sqrt(muvstore(NGLLX,1,NGLLZ,ispec)/rhostore(NGLLX,1,NGLLZ,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(NGLLX,1,NGLLZ,ispec)**2 + ystore(NGLLX,1,NGLLZ,ispec)**2 + zstore(NGLLX,1,NGLLZ,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(5))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(5)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
+ sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
+ vmax = sqrt((kappavstore(1,1,NGLLZ,ispec)+4.*muvstore(1,1,NGLLZ,ispec)/3.)/rhostore(1,1,NGLLZ,ispec))
+ vmin = sqrt(muvstore(1,1,NGLLZ,ispec)/rhostore(1,1,NGLLZ,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(1,1,NGLLZ,ispec)**2 + ystore(1,1,NGLLZ,ispec)**2 + zstore(1,1,NGLLZ,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ mask_ibool(iglobval(1)) = .true.
+ mask_ibool(iglobval(2)) = .true.
+ mask_ibool(iglobval(6)) = .true.
+ mask_ibool(iglobval(5)) = .true.
+ endif
+
+! face eta = eta_max
+ if(iboun(4,ispec)) then
+
+ if(.not. mask_ibool(iglobval(4))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(4)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
+ sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
+ vmax = sqrt((kappavstore(1,NGLLY,1,ispec)+4.*muvstore(1,NGLLY,1,ispec)/3.)/rhostore(1,NGLLY,1,ispec))
+ vmin = sqrt(muvstore(1,NGLLY,1,ispec)/rhostore(1,NGLLY,1,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(1,NGLLY,1,ispec)**2 + ystore(1,NGLLY,1,ispec)**2 + zstore(1,NGLLY,1,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(3))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(3)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
+ vmax = sqrt((kappavstore(NGLLX,NGLLY,1,ispec)+4.*muvstore(NGLLX,NGLLY,1,ispec)/3.)/rhostore(NGLLX,NGLLY,1,ispec))
+ vmin = sqrt(muvstore(NGLLX,NGLLY,1,ispec)/rhostore(NGLLX,NGLLY,1,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(NGLLX,NGLLY,1,ispec)**2 + ystore(NGLLX,NGLLY,1,ispec)**2 + zstore(NGLLX,NGLLY,1,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(7))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(7)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
+ vmax = sqrt((kappavstore(NGLLX,NGLLY,NGLLZ,ispec)+4.*muvstore(NGLLX,NGLLY,NGLLZ,ispec)/3.)/rhostore(NGLLX,NGLLY,NGLLZ,ispec))
+ vmin = sqrt(muvstore(NGLLX,NGLLY,NGLLZ,ispec)/rhostore(NGLLX,NGLLY,NGLLZ,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(NGLLX,NGLLY,NGLLZ,ispec)**2 + ystore(NGLLX,NGLLY,NGLLZ,ispec)**2 + zstore(NGLLX,NGLLY,NGLLZ,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ if(.not. mask_ibool(iglobval(8))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(8)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
+ vmax = sqrt((kappavstore(1,NGLLY,NGLLZ,ispec)+4.*muvstore(1,NGLLY,NGLLZ,ispec)/3.)/rhostore(1,NGLLY,NGLLZ,ispec))
+ vmin = sqrt(muvstore(1,NGLLY,NGLLZ,ispec)/rhostore(1,NGLLY,NGLLZ,ispec))
+! particular case of the outer core (muvstore contains 1/rho)
+ if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
+ r = dsqrt(xstore(1,NGLLY,NGLLZ,ispec)**2 + ystore(1,NGLLY,NGLLZ,ispec)**2 + zstore(1,NGLLY,NGLLZ,ispec)**2)
+ call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
+ vmax = vp
+ vmin = vp
+ endif
+ if(vmin == 0.0) vmin=vmax
+ write(11,*) numpoin,vmin,vmax
+ endif
+
+ mask_ibool(iglobval(4)) = .true.
+ mask_ibool(iglobval(3)) = .true.
+ mask_ibool(iglobval(7)) = .true.
+ mask_ibool(iglobval(8)) = .true.
+ endif
+
+ endif
+ enddo
+
+! check that number of global points output is okay
+ if(numpoin /= npoin) &
+ call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
+
+ close(10)
+ close(11)
+
+! output global AVS or DX elements
+
+! writing elements
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='unknown')
+ if(ISOTROPIC_3D_MANTLE) &
+ open(unit=11,file=prname(1:len_trim(prname))//'AVS_DXelementschunks_dvp_dvs.txt',status='unknown')
+
+! number of elements in AVS or DX file
+ write(10,*) nspecface
+
+ ispecface = 0
+ do ispec=1,nspec
+! only if on face
+ if(iboun(1,ispec) .or. iboun(2,ispec) .or. &
+ iboun(3,ispec) .or. iboun(4,ispec)) then
+ iglobval(1)=ibool(1,1,1,ispec)
+ iglobval(2)=ibool(NGLLX,1,1,ispec)
+ iglobval(3)=ibool(NGLLX,NGLLY,1,ispec)
+ iglobval(4)=ibool(1,NGLLY,1,ispec)
+ iglobval(5)=ibool(1,1,NGLLZ,ispec)
+ iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
+ iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
+
+! include lateral variations if needed
+
+ if(ISOTROPIC_3D_MANTLE) then
+! pick a point within the element and get its radius
+ r=dsqrt(xstore(2,2,2,ispec)**2+ystore(2,2,2,ispec)**2+zstore(2,2,2,ispec)**2)
+
+ if(r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then
+! average over the element
+ dvp = 0.0
+ dvs = 0.0
+ np =0
+ do k=2,NGLLZ-1
+ do j=2,NGLLY-1
+ do i=2,NGLLX-1
+ np=np+1
+ x=xstore(i,j,k,ispec)
+ y=ystore(i,j,k,ispec)
+ z=zstore(i,j,k,ispec)
+ r=dsqrt(x*x+y*y+z*z)
+ ! take out ellipticity
+ if(ELLIPTICITY) then
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi_dummy)
+ cost=dcos(theta)
+ p20=0.5d0*(3.0d0*cost*cost-1.0d0)
+ call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
+ factor=ONE-(TWO/3.0d0)*ell*p20
+ r=r/factor
+ endif
+
+
+ ! gets reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
+ call meshfem3D_models_get1D_val(myrank,iregion_code,idoubling(ispec), &
+ r,rho,vpv,vph,vsv,vsh,eta_aniso, &
+ Qkappa,Qmu,RICB,RCMB, &
+ RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
+ RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ ! calculates isotropic values
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
+ + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
+ + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+
+ if( abs(rhostore(i,j,k,ispec))< 1.e-20 ) then
+ print*,' attention: rhostore close to zero',rhostore(i,j,k,ispec),r,i,j,k,ispec
+ dvp = 0.0
+ dvs = 0.0
+ else if( abs(sngl(vp))< 1.e-20 ) then
+ print*,' attention: vp close to zero',sngl(vp),r,i,j,k,ispec
+ dvp = 0.0
+ else if( abs(sngl(vs))< 1.e-20 ) then
+ print*,' attention: vs close to zero',sngl(vs),r,i,j,k,ispec
+ dvs = 0.0
+ else
+ dvp = dvp + (sqrt((kappavstore(i,j,k,ispec)+4.*muvstore(i,j,k,ispec)/3.)/rhostore(i,j,k,ispec)) - sngl(vp))/sngl(vp)
+ dvs = dvs + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) - sngl(vs))/sngl(vs)
+ endif
+
+ enddo
+ enddo
+ enddo
+ dvp = dvp / np
+ dvs = dvs / np
+ else
+ dvp = 0.0
+ dvs = 0.0
+ endif
+ endif
+
+! face xi = xi_min
+ if(iboun(1,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(1)), &
+ num_ibool_AVS_DX(iglobval(4)),num_ibool_AVS_DX(iglobval(8)), &
+ num_ibool_AVS_DX(iglobval(5))
+ if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
+ endif
+
+! face xi = xi_max
+ if(iboun(2,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(2)), &
+ num_ibool_AVS_DX(iglobval(3)),num_ibool_AVS_DX(iglobval(7)), &
+ num_ibool_AVS_DX(iglobval(6))
+ if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
+ endif
+
+! face eta = eta_min
+ if(iboun(3,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(1)), &
+ num_ibool_AVS_DX(iglobval(2)),num_ibool_AVS_DX(iglobval(6)), &
+ num_ibool_AVS_DX(iglobval(5))
+ if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
+ endif
+
+! face eta = eta_max
+ if(iboun(4,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(4)), &
+ num_ibool_AVS_DX(iglobval(3)),num_ibool_AVS_DX(iglobval(7)), &
+ num_ibool_AVS_DX(iglobval(8))
+ if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
+ endif
+
+ endif
+ enddo
+
+! check that number of surface elements output is okay
+ if(ispecface /= nspecface) &
+ call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation')
+
+ close(10)
+ if(ISOTROPIC_3D_MANTLE) close(11)
+
+ end subroutine write_AVS_DX_global_chunks_data
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_data.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_data.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,370 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create AVS or DX 3D data for the slice, to be recombined in postprocessing
+ subroutine write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling, &
+ xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,npointot)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to output global points only once
+ integer npointot
+ logical mask_ibool(npointot)
+
+! numbering of global AVS or DX points
+ integer num_ibool_AVS_DX(npointot)
+
+ integer ispec
+ integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
+ integer npoin,numpoin
+
+! processor identification
+ character(len=150) prname
+
+! writing points
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpoints.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! mark global AVS or DX points
+ do ispec=1,nspec
+ iglob1=ibool(1,1,1,ispec)
+ iglob2=ibool(NGLLX,1,1,ispec)
+ iglob3=ibool(NGLLX,NGLLY,1,ispec)
+ iglob4=ibool(1,NGLLY,1,ispec)
+ iglob5=ibool(1,1,NGLLZ,ispec)
+ iglob6=ibool(NGLLX,1,NGLLZ,ispec)
+ iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglob8=ibool(1,NGLLY,NGLLZ,ispec)
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob5) = .true.
+ mask_ibool(iglob6) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob8) = .true.
+ enddo
+
+! count global number of AVS or DX points
+ npoin = count(mask_ibool(:))
+
+! number of points in AVS or DX file
+ write(10,*) npoin
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! output global AVS or DX points
+ numpoin = 0
+ do ispec=1,nspec
+ iglob1=ibool(1,1,1,ispec)
+ iglob2=ibool(NGLLX,1,1,ispec)
+ iglob3=ibool(NGLLX,NGLLY,1,ispec)
+ iglob4=ibool(1,NGLLY,1,ispec)
+ iglob5=ibool(1,1,NGLLZ,ispec)
+ iglob6=ibool(NGLLX,1,NGLLZ,ispec)
+ iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglob8=ibool(1,NGLLY,NGLLZ,ispec)
+ if(.not. mask_ibool(iglob1)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob1) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
+ sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob2)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob2) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
+ sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob3)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob3) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob4)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob4) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
+ sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob5)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob5) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
+ sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob6)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob6) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob7)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob7) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob8)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob8) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
+ endif
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob5) = .true.
+ mask_ibool(iglob6) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob8) = .true.
+ enddo
+
+! check that number of global points output is okay
+ if(numpoin /= npoin) &
+ call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
+
+ close(10)
+
+! writing elements
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelements.txt',status='unknown')
+
+! number of elements in AVS or DX file
+ write(10,*) nspec
+
+! output global AVS or DX elements
+ do ispec=1,nspec
+ iglob1=ibool(1,1,1,ispec)
+ iglob2=ibool(NGLLX,1,1,ispec)
+ iglob3=ibool(NGLLX,NGLLY,1,ispec)
+ iglob4=ibool(1,NGLLY,1,ispec)
+ iglob5=ibool(1,1,NGLLZ,ispec)
+ iglob6=ibool(NGLLX,1,NGLLZ,ispec)
+ iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglob8=ibool(1,NGLLY,NGLLZ,ispec)
+ write(10,*) ispec,idoubling(ispec),num_ibool_AVS_DX(iglob1), &
+ num_ibool_AVS_DX(iglob2),num_ibool_AVS_DX(iglob3), &
+ num_ibool_AVS_DX(iglob4),num_ibool_AVS_DX(iglob5), &
+ num_ibool_AVS_DX(iglob6),num_ibool_AVS_DX(iglob7), &
+ num_ibool_AVS_DX(iglob8)
+ enddo
+
+ close(10)
+
+ end subroutine write_AVS_DX_global_data
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+!> Hejun
+! write material information for gll points
+ subroutine write_AVS_DX_global_data_gll(prname,nspec, &
+ xstore,ystore,zstore,rhostore,kappavstore,muvstore,Qmustore,&
+ ATTENUATION)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec
+ character(len=150) prname
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision:: Qmustore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ logical :: ATTENUATION
+
+ ! local parameters
+ double precision,dimension(8):: vp,vs,rho,Qmu
+ double precision:: vp_average,vs_average,rho_average,Qmu_average
+
+ integer flag(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer ispec,i,j,k
+ integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
+ integer numpoin,nelem
+
+
+! writing points
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpoints_gll.txt',status='unknown')
+
+! number of points in AVS or DX file
+ write(10,*) nspec*NGLLX*NGLLY*NGLLZ
+
+
+! output global AVS or DX points
+ numpoin = 0
+ do ispec=1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ numpoin = numpoin + 1
+ write(10,*) numpoin,sngl(xstore(i,j,k,ispec)),&
+ sngl(ystore(i,j,k,ispec)),sngl(zstore(i,j,k,ispec))
+ flag(i,j,k,ispec) = numpoin
+ end do
+ end do
+ end do
+ enddo
+
+ close(10)
+
+! writing elements
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelements_gll.txt',status='unknown')
+
+
+! number of elements in AVS or DX file
+ write(10,*) nspec*(NGLLX-1)*(NGLLY-1)*(NGLLZ-1)
+
+ nelem = 0
+! output global AVS or DX elements
+ do ispec=1,nspec
+ do k = 1,NGLLZ-1
+ do j = 1,NGLLY-1
+ do i = 1,NGLLX-1
+ nelem = nelem + 1
+ iglob1=flag(i,j,k,ispec)
+ iglob2=flag(i+1,j,k,ispec)
+ iglob3=flag(i+1,j+1,k,ispec)
+ iglob4=flag(i,j+1,k,ispec)
+ iglob5=flag(i,j,k+1,ispec)
+ iglob6=flag(i+1,j,k+1,ispec)
+ iglob7=flag(i+1,j+1,k+1,ispec)
+ iglob8=flag(i,j+1,k+1,ispec)
+
+ write(10,*) nelem,iglob1, &
+ iglob2,iglob3,iglob4,&
+ iglob5,iglob6,iglob7,iglob8
+ end do
+ end do
+ end do
+ enddo
+
+ close(10)
+
+! writing elements properity
+ open(unit=1001,file=prname(1:len_trim(prname))//'AVS_DXmaterials_gll.txt',status='unknown')
+
+! number of elements in AVS or DX file
+ write(1001,*) nspec*(NGLLX-1)*(NGLLY-1)*(NGLLZ-1)
+
+ nelem = 0
+! output global AVS or DX elements
+ do ispec=1,nspec
+ do k = 1,NGLLZ-1
+ do j = 1,NGLLY-1
+ do i = 1,NGLLX-1
+ nelem = nelem + 1
+ rho(1)=dble(rhostore(i,j,k,ispec))
+ vs(1)=dble(sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)))
+ vp(1)=dble(sqrt(kappavstore(i,j,k,ispec)/rhostore(i,j,k,ispec)+4.d0*vs(1)*vs(1)/3.d0))
+
+ rho(2)=dble(rhostore(i+1,j,k,ispec))
+ vs(2)=dble(sqrt(muvstore(i+1,j,k,ispec)/rhostore(i+1,j,k,ispec)))
+ vp(2)=dble(sqrt(kappavstore(i+1,j,k,ispec)/rhostore(i+1,j,k,ispec)+4.d0*vs(2)*vs(2)/3.d0))
+
+ rho(3)=dble(rhostore(i+1,j+1,k,ispec))
+ vs(3)=dble(sqrt(muvstore(i+1,j+1,k,ispec)/rhostore(i+1,j+1,k,ispec)))
+ vp(3)=dble(sqrt(kappavstore(i+1,j+1,k,ispec)/rhostore(i+1,j+1,k,ispec)+4.d0*vs(3)*vs(3)/3.d0))
+
+ rho(4)=dble(rhostore(i,j+1,k,ispec))
+ vs(4)=dble(sqrt(muvstore(i,j+1,k,ispec)/rhostore(i,j+1,k,ispec)))
+ vp(4)=dble(sqrt(kappavstore(i,j+1,k,ispec)/rhostore(i,j+1,k,ispec)+4.d0*vs(4)*vs(4)/3.d0))
+
+ rho(5)=dble(rhostore(i,j,k+1,ispec))
+ vs(5)=dble(sqrt(muvstore(i,j,k+1,ispec)/rhostore(i,j,k+1,ispec)))
+ vp(5)=dble(sqrt(kappavstore(i,j,k+1,ispec)/rhostore(i,j,k+1,ispec)+4.d0*vs(5)*vs(5)/3.d0))
+
+ rho(6)=dble(rhostore(i+1,j,k+1,ispec))
+ vs(6)=dble(sqrt(muvstore(i+1,j,k+1,ispec)/rhostore(i+1,j,k+1,ispec)))
+ vp(6)=dble(sqrt(kappavstore(i+1,j,k+1,ispec)/rhostore(i+1,j,k+1,ispec)+4.d0*vs(6)*vs(6)/3.d0))
+
+ rho(7)=dble(rhostore(i+1,j+1,k+1,ispec))
+ vs(7)=dble(sqrt(muvstore(i+1,j+1,k+1,ispec)/rhostore(i+1,j+1,k+1,ispec)))
+ vp(7)=dble(sqrt(kappavstore(i+1,j+1,k+1,ispec)/rhostore(i+1,j+1,k+1,ispec)+4.d0*vs(7)*vs(7)/3.d0))
+
+ rho(8)=dble(rhostore(i,j+1,k+1,ispec))
+ vs(8)=dble(sqrt(muvstore(i,j+1,k+1,ispec)/rhostore(i,j+1,k+1,ispec)))
+ vp(8)=dble(sqrt(kappavstore(i,j+1,k+1,ispec)/rhostore(i,j+1,k+1,ispec)+4.d0*vs(8)*vs(8)/3.d0))
+
+ if (ATTENUATION) then
+ Qmu(1)=dble(Qmustore(i,j,k,ispec))
+ Qmu(2)=dble(Qmustore(i+1,j,k,ispec))
+ Qmu(3)=dble(Qmustore(i+1,j+1,k,ispec))
+ Qmu(4)=dble(Qmustore(i,j+1,k,ispec))
+ Qmu(5)=dble(Qmustore(i,j,k+1,ispec))
+ Qmu(6)=dble(Qmustore(i+1,j,k+1,ispec))
+ Qmu(7)=dble(Qmustore(i+1,j+1,k+1,ispec))
+ Qmu(8)=dble(Qmustore(i,j+1,k+1,ispec))
+ Qmu_average=Qmu(1)
+ end if
+ !rho_average=sum(rho(1:4))/4.d0
+ !vp_average=sum(vp(1:4))/4.d0
+ !vs_average=sum(vs(1:4))/4.d0
+ rho_average=rho(1)
+ vp_average=vp(1)
+ vs_average=vs(1)
+
+ if (ATTENUATION) then
+ write(1001,*) nelem,rho_average,vp_average,vs_average,Qmu_average
+ else
+ write(1001,*) nelem,rho_average,vp_average,vs_average
+ end if
+
+ end do
+ end do
+ end do
+ enddo
+
+ close(1001)
+
+ end subroutine write_AVS_DX_global_data_gll
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_faces_data.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_faces_data.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_faces_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_global_faces_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,451 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create AVS or DX 2D data for the faces of the slice,
+! to be recombined in postprocessing
+
+ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta, &
+ ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
+ npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
+
+ logical iMPIcut_xi(2,nspec)
+ logical iMPIcut_eta(2,nspec)
+
+ double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
+ R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to output global points only once
+ integer npointot
+ logical mask_ibool(npointot)
+
+! numbering of global AVS or DX points
+ integer num_ibool_AVS_DX(npointot)
+
+ integer ispec
+ integer i,j,k,np
+ integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
+ integer npoin,numpoin,nspecface,ispecface
+
+ double precision r,rho,vp,vs,Qkappa,Qmu
+ double precision vpv,vph,vsv,vsh,eta_aniso
+ double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
+ real(kind=CUSTOM_REAL) dvp,dvs
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+! processor identification
+ character(len=150) prname
+
+ integer iregion_code
+
+! writing points
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+ nspecface = 0
+
+! mark global AVS or DX points
+ do ispec=1,nspec
+! only if on face
+ if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
+ iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
+ iglob1=ibool(1,1,1,ispec)
+ iglob2=ibool(NGLLX,1,1,ispec)
+ iglob3=ibool(NGLLX,NGLLY,1,ispec)
+ iglob4=ibool(1,NGLLY,1,ispec)
+ iglob5=ibool(1,1,NGLLZ,ispec)
+ iglob6=ibool(NGLLX,1,NGLLZ,ispec)
+ iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglob8=ibool(1,NGLLY,NGLLZ,ispec)
+
+! face xi = xi_min
+ if(iMPIcut_xi(1,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob8) = .true.
+ mask_ibool(iglob5) = .true.
+ endif
+
+! face xi = xi_max
+ if(iMPIcut_xi(2,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob6) = .true.
+ endif
+
+! face eta = eta_min
+ if(iMPIcut_eta(1,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob6) = .true.
+ mask_ibool(iglob5) = .true.
+ endif
+
+! face eta = eta_max
+ if(iMPIcut_eta(2,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob8) = .true.
+ endif
+
+ endif
+ enddo
+
+! count global number of AVS or DX points
+ npoin = count(mask_ibool(:))
+
+! number of points in AVS or DX file
+ write(10,*) npoin
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! output global AVS or DX points
+ numpoin = 0
+ do ispec=1,nspec
+! only if on face
+ if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
+ iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
+ iglob1=ibool(1,1,1,ispec)
+ iglob2=ibool(NGLLX,1,1,ispec)
+ iglob3=ibool(NGLLX,NGLLY,1,ispec)
+ iglob4=ibool(1,NGLLY,1,ispec)
+ iglob5=ibool(1,1,NGLLZ,ispec)
+ iglob6=ibool(NGLLX,1,NGLLZ,ispec)
+ iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglob8=ibool(1,NGLLY,NGLLZ,ispec)
+
+! face xi = xi_min
+ if(iMPIcut_xi(1,ispec)) then
+ if(.not. mask_ibool(iglob1)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob1) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
+ sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob4)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob4) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
+ sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob8)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob8) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob5)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob5) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
+ sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
+ endif
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob8) = .true.
+ mask_ibool(iglob5) = .true.
+ endif
+
+! face xi = xi_max
+ if(iMPIcut_xi(2,ispec)) then
+ if(.not. mask_ibool(iglob2)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob2) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
+ sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob3)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob3) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob7)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob7) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob6)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob6) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
+ endif
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob6) = .true.
+ endif
+
+! face eta = eta_min
+ if(iMPIcut_eta(1,ispec)) then
+ if(.not. mask_ibool(iglob1)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob1) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
+ sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob2)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob2) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
+ sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob6)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob6) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob5)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob5) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
+ sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
+ endif
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob6) = .true.
+ mask_ibool(iglob5) = .true.
+ endif
+
+! face eta = eta_max
+ if(iMPIcut_eta(2,ispec)) then
+ if(.not. mask_ibool(iglob4)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob4) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
+ sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob3)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob3) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob7)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob7) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob8)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob8) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
+ endif
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob8) = .true.
+ endif
+
+ endif
+ enddo
+
+! check that number of global points output is okay
+ if(numpoin /= npoin) &
+ call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
+
+ close(10)
+
+! output global AVS or DX elements
+
+! writing elements
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='unknown')
+ if(ISOTROPIC_3D_MANTLE) &
+ open(unit=11,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces_dvp_dvs.txt',status='unknown')
+
+! number of elements in AVS or DX file
+ write(10,*) nspecface
+
+ ispecface = 0
+ do ispec=1,nspec
+! only if on face
+ if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
+ iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
+ iglob1=ibool(1,1,1,ispec)
+ iglob2=ibool(NGLLX,1,1,ispec)
+ iglob3=ibool(NGLLX,NGLLY,1,ispec)
+ iglob4=ibool(1,NGLLY,1,ispec)
+ iglob5=ibool(1,1,NGLLZ,ispec)
+ iglob6=ibool(NGLLX,1,NGLLZ,ispec)
+ iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglob8=ibool(1,NGLLY,NGLLZ,ispec)
+
+! include lateral variations if needed
+
+ if(ISOTROPIC_3D_MANTLE) then
+ ! pick a point within the element and get its radius
+ r=dsqrt(xstore(2,2,2,ispec)**2+ystore(2,2,2,ispec)**2+zstore(2,2,2,ispec)**2)
+
+ if(r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then
+ ! average over the element
+ dvp = 0.0
+ dvs = 0.0
+ np =0
+ do k=2,NGLLZ-1
+ do j=2,NGLLY-1
+ do i=2,NGLLX-1
+ np=np+1
+ x=xstore(i,j,k,ispec)
+ y=ystore(i,j,k,ispec)
+ z=zstore(i,j,k,ispec)
+ r=dsqrt(x*x+y*y+z*z)
+ ! take out ellipticity
+ if(ELLIPTICITY) then
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi_dummy)
+ cost=dcos(theta)
+ p20=0.5d0*(3.0d0*cost*cost-1.0d0)
+ call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
+ factor=ONE-(TWO/3.0d0)*ell*p20
+ r=r/factor
+ endif
+
+
+ ! gets reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
+ call meshfem3D_models_get1D_val(myrank,iregion_code,idoubling(ispec), &
+ r,rho,vpv,vph,vsv,vsh,eta_aniso, &
+ Qkappa,Qmu,RICB,RCMB, &
+ RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
+ RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ ! calculates isotropic values
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
+ + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
+ + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+
+ if( abs(rhostore(i,j,k,ispec))< 1.e-20 ) then
+ print*,' attention: rhostore close to zero',rhostore(i,j,k,ispec),r,i,j,k,ispec
+ dvp = 0.0
+ dvs = 0.0
+ else if( abs(sngl(vp))< 1.e-20 ) then
+ print*,' attention: vp close to zero',sngl(vp),r,i,j,k,ispec
+ dvp = 0.0
+ else if( abs(sngl(vs))< 1.e-20 ) then
+ print*,' attention: vs close to zero',sngl(vs),r,i,j,k,ispec
+ dvs = 0.0
+ else
+ dvp = dvp + (sqrt((kappavstore(i,j,k,ispec)+4.*muvstore(i,j,k,ispec)/3.)/rhostore(i,j,k,ispec)) - sngl(vp))/sngl(vp)
+ dvs = dvs + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) - sngl(vs))/sngl(vs)
+ endif
+
+ enddo
+ enddo
+ enddo
+ dvp = dvp / np
+ dvs = dvs / np
+ else
+ dvp = 0.0
+ dvs = 0.0
+ endif
+ endif
+
+! face xi = xi_min
+ if(iMPIcut_xi(1,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob1), &
+ num_ibool_AVS_DX(iglob4),num_ibool_AVS_DX(iglob8), &
+ num_ibool_AVS_DX(iglob5)
+ if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
+ endif
+
+! face xi = xi_max
+ if(iMPIcut_xi(2,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob2), &
+ num_ibool_AVS_DX(iglob3),num_ibool_AVS_DX(iglob7), &
+ num_ibool_AVS_DX(iglob6)
+ if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
+ endif
+
+! face eta = eta_min
+ if(iMPIcut_eta(1,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob1), &
+ num_ibool_AVS_DX(iglob2),num_ibool_AVS_DX(iglob6), &
+ num_ibool_AVS_DX(iglob5)
+ if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
+ endif
+
+! face eta = eta_max
+ if(iMPIcut_eta(2,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob4), &
+ num_ibool_AVS_DX(iglob3),num_ibool_AVS_DX(iglob7), &
+ num_ibool_AVS_DX(iglob8)
+ if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
+ endif
+
+ endif
+ enddo
+
+! check that number of surface elements output is okay
+ if(ispecface /= nspecface) &
+ call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation')
+
+ close(10)
+ if(ISOTROPIC_3D_MANTLE) close(11)
+
+ end subroutine write_AVS_DX_global_faces_data
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_surface_data.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_surface_data.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_surface_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_AVS_DX_surface_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,287 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create AVS or DX 2D data for the surface of the model
+! to be recombined in postprocessing
+ subroutine write_AVS_DX_surface_data(myrank,prname,nspec,iboun, &
+ ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,npointot,&
+ rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ logical iboun(6,nspec)
+ logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
+
+ double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
+ R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ double precision r,rho,vp,vs,Qkappa,Qmu
+ double precision vpv,vph,vsv,vsh,eta_aniso
+ double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
+ real(kind=CUSTOM_REAL) dvp,dvs
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to output global points only once
+ integer npointot
+ logical mask_ibool(npointot)
+
+! numbering of global AVS or DX points
+ integer num_ibool_AVS_DX(npointot)
+
+ integer ispec
+ integer i,j,k,np
+ integer, dimension(8) :: iglobval
+ integer npoin,numpoin,nspecface,ispecface
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+! processor identification
+ character(len=150) prname
+
+ integer iregion_code
+
+! writing points
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+ nspecface = 0
+
+! mark global AVS or DX points
+ do ispec=1,nspec
+! only if at the surface (top plane)
+ if(iboun(6,ispec)) then
+
+ iglobval(5)=ibool(1,1,NGLLZ,ispec)
+ iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
+ iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
+
+! element is at the surface
+ nspecface = nspecface + 1
+ mask_ibool(iglobval(5)) = .true.
+ mask_ibool(iglobval(6)) = .true.
+ mask_ibool(iglobval(7)) = .true.
+ mask_ibool(iglobval(8)) = .true.
+
+ endif
+ enddo
+
+! count global number of AVS or DX points
+ npoin = count(mask_ibool(:))
+
+! number of points in AVS or DX file
+ write(10,*) npoin
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! output global AVS or DX points
+ numpoin = 0
+ do ispec=1,nspec
+! only if at the surface
+ if(iboun(6,ispec)) then
+
+ iglobval(5)=ibool(1,1,NGLLZ,ispec)
+ iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
+ iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
+
+! top face
+ if(iboun(6,ispec)) then
+
+ if(.not. mask_ibool(iglobval(5))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(5)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
+ sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
+ endif
+
+ if(.not. mask_ibool(iglobval(6))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(6)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
+ endif
+
+ if(.not. mask_ibool(iglobval(7))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(7)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
+ endif
+
+ if(.not. mask_ibool(iglobval(8))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(8)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
+ endif
+
+ mask_ibool(iglobval(5)) = .true.
+ mask_ibool(iglobval(6)) = .true.
+ mask_ibool(iglobval(7)) = .true.
+ mask_ibool(iglobval(8)) = .true.
+
+ endif
+
+ endif
+ enddo
+
+! check that number of global points output is okay
+ if(numpoin /= npoin) &
+ call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
+
+ close(10)
+
+! output global AVS or DX elements
+
+! writing elements
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='unknown')
+ if(ISOTROPIC_3D_MANTLE) &
+ open(unit=11,file=prname(1:len_trim(prname))//'AVS_DXelementssurface_dvp_dvs.txt',status='unknown')
+
+! number of elements in AVS or DX file
+ write(10,*) nspecface
+
+ ispecface = 0
+ do ispec=1,nspec
+! only if at the surface
+ if(iboun(6,ispec)) then
+
+ iglobval(5)=ibool(1,1,NGLLZ,ispec)
+ iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
+ iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
+
+ if(ISOTROPIC_3D_MANTLE) then
+ ! pick a point within the element and get its radius
+ r=dsqrt(xstore(2,2,2,ispec)**2+ystore(2,2,2,ispec)**2+zstore(2,2,2,ispec)**2)
+
+ if(r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then
+ ! average over the element
+ dvp = 0.0
+ dvs = 0.0
+ np =0
+ do k=2,NGLLZ-1
+ do j=2,NGLLY-1
+ do i=2,NGLLX-1
+ np=np+1
+ x=xstore(i,j,k,ispec)
+ y=ystore(i,j,k,ispec)
+ z=zstore(i,j,k,ispec)
+ r=dsqrt(x*x+y*y+z*z)
+ ! take out ellipticity
+ if(ELLIPTICITY) then
+ call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi_dummy)
+ cost=dcos(theta)
+ p20=0.5d0*(3.0d0*cost*cost-1.0d0)
+ call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
+ factor=ONE-(TWO/3.0d0)*ell*p20
+ r=r/factor
+ endif
+
+
+ ! gets reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
+ call meshfem3D_models_get1D_val(myrank,iregion_code,idoubling(ispec), &
+ r,rho,vpv,vph,vsv,vsh,eta_aniso, &
+ Qkappa,Qmu,RICB,RCMB, &
+ RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
+ RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ ! calculates isotropic values
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
+ + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
+ + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+
+ if( abs(rhostore(i,j,k,ispec))< 1.e-20 ) then
+ print*,' attention: rhostore close to zero',rhostore(i,j,k,ispec),r,i,j,k,ispec
+ dvp = 0.0
+ dvs = 0.0
+ else if( abs(sngl(vp))< 1.e-20 ) then
+ print*,' attention: vp close to zero',sngl(vp),r,i,j,k,ispec
+ dvp = 0.0
+ else if( abs(sngl(vs))< 1.e-20 ) then
+ print*,' attention: vs close to zero',sngl(vs),r,i,j,k,ispec
+ dvs = 0.0
+ else
+ dvp = dvp + (sqrt((kappavstore(i,j,k,ispec)+4.*muvstore(i,j,k,ispec)/3.) &
+ /rhostore(i,j,k,ispec)) - sngl(vp))/sngl(vp)
+ dvs = dvs + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) - sngl(vs))/sngl(vs)
+ endif
+
+ enddo
+ enddo
+ enddo
+ dvp = dvp / np
+ dvs = dvs / np
+ else
+ dvp = 0.0
+ dvs = 0.0
+ endif
+ endif
+
+ ! top face
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(5)), &
+ num_ibool_AVS_DX(iglobval(6)),num_ibool_AVS_DX(iglobval(7)), &
+ num_ibool_AVS_DX(iglobval(8))
+ if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
+
+ endif
+ enddo
+
+! check that number of surface elements output is okay
+ if(ispecface /= nspecface) &
+ call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation')
+
+ close(10)
+ if(ISOTROPIC_3D_MANTLE) close(11)
+
+ end subroutine write_AVS_DX_surface_data
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_c_binary.c (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/write_c_binary.c)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_c_binary.c (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_c_binary.c 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,651 @@
+/*
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! December 2010
+!
+! 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.
+!
+!=====================================================================
+*/
+
+// after Brian's function
+
+#include "config.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+static int fd;
+
+void
+FC_FUNC_(open_file_create,OPEN_FILE)(char *file) {
+ /* fprintf(stderr, "Opening file: %s\n", file); */
+ fd = open(file, O_WRONLY | O_CREAT | O_TRUNC, 0644);
+ if(fd == -1) {
+ fprintf(stderr, "Error opening file: %s exiting\n", file);
+ exit(-1);
+ }
+}
+
+void
+FC_FUNC_(open_file_append,OPEN_FILE)(char *file) {
+ /* fprintf(stderr, "Opening file: %s\n", file); */
+ fd = open(file, O_WRONLY | O_CREAT | O_APPEND, 0644);
+ if(fd == -1) {
+ fprintf(stderr, "Error opening file: %s exiting\n", file);
+ exit(-1);
+ }
+}
+
+void
+FC_FUNC_(close_file,CLOSE_FILE)() {
+ /* fprintf(stderr, "Closing file\n"); */
+ close(fd);
+}
+
+void
+FC_FUNC_(write_integer,WRITE_INTEGER)(int *z) {
+ int dummy_unused_variable = write(fd, z, sizeof(int));
+}
+
+void
+FC_FUNC_(write_real,WRITE_REAL)(float *z) {
+ int dummy_unused_variable = write(fd, z, sizeof(float));
+}
+
+/* BS BS begin. Added section for writing SAC binary data*/
+void
+FC_FUNC_(write_n_real,WRITE_N_REAL)(float *z,int *n) {
+ int dummy_unused_variable = write(fd, z, *n*sizeof(float));
+}
+
+void
+FC_FUNC_(write_character,WRITE_CHARACTER)(char *z, int *lchar) {
+ int dummy_unused_variable = write(fd, z, *lchar*sizeof(char));
+}
+
+// LQY -- added for combine_vol/surf_data to write multiple binary files simultaneously --
+
+void
+FC_FUNC_(open_file_fd,OPEN_FILE_FD)(char *file, int *pfd) {
+ /* fprintf(stderr, "Opening file: %s\n", file); */
+ *pfd = open(file, O_WRONLY | O_CREAT, 0644);
+ if(*pfd == -1) {
+ fprintf(stderr, "Error opening file: %s exiting\n", file);
+ exit(-1);
+ }
+}
+
+void
+FC_FUNC_(close_file_fd,CLOSE_FILE_FD)(int *pfd) {
+ /* fprintf(stderr, "Closing file\n"); */
+ close(*pfd);
+}
+
+void
+FC_FUNC_(write_integer_fd,WRITE_INTEGER_FD)(int *pfd, int *z) {
+ int dummy_unused_variable = write(*pfd, z, sizeof(int));
+}
+
+void
+FC_FUNC_(write_real_fd,WRITE_REAL_FD)(int *pfd, float *z) {
+ int dummy_unused_variable = write(*pfd, z, sizeof(float));
+}
+
+/* BS BS begin. Added section for writing SAC binary data*/
+void
+FC_FUNC_(write_n_real_fd,WRITE_N_REAL_FD)(int *pfd, float *z,int *n) {
+ int dummy_unused_variable = write(*pfd, z, *n*sizeof(float));
+}
+
+void
+FC_FUNC_(write_character_fd,WRITE_CHARACTER_FD)(int *pfd, char *z, int *lchar) {
+ int dummy_unused_variable = write(*pfd, z, *lchar*sizeof(char));
+}
+
+
+/* ---------------------------------------
+
+ IO performance test
+
+ Software Optimization for High Performance Computing: Creating Faster Applications
+
+ By Isom L. Crawford and Kevin R. Wadleigh
+ Jul 18, 2003
+
+ - uses functions fopen/fread/fwrite for binary file I/O
+
+ --------------------------------------- */
+
+#define __USE_GNU
+#include <string.h>
+#include <regex.h>
+
+#define MIN(x,y) ((x) < (y) ? (x) : (y))
+
+/* fastest performance on nehalem nodes:
+
+Linux 2.6.18-164.11.1.el5 #1 SMP Wed Jan 20 10:04:55 EST 2010 x86_64 x86_64 x86_64 GNU/Linux
+
+achieved with 16 KB buffers: */
+
+//#define MAX_B 65536 // 64 KB
+//#define MAX_B 32768 // 32 KB
+#define MAX_B 16384 // 16 KB
+//#define MAX_B 8192 // 8 KB
+
+// absorbing files: instead of passing file descriptor, we use the array index
+// first 0 - 3 indices for crust mantle files
+// last 4 - 8 indices for outer core files
+#define ABS_FILEID 9
+
+// file points
+static FILE * fp_abs[ABS_FILEID];
+// file work buffers
+static char * work_buffer[ABS_FILEID];
+
+
+//void
+//FC_FUNC_(open_file_abs_r_fbin,OPEN_FILE_ABS_R_FBIN)(int *fid, char *filename,int *length, int *filesize){
+void open_file_abs_r_fbin(int *fid, char *filename,int *length, int *filesize){
+
+// opens file for read access
+
+//This sequence assigns the MAX_B array work_buffer to the file pointer
+// to be used for its buffering. performance should benefit.
+ char * fncopy;
+ char * blank;
+ FILE *ft;
+
+ // checks filesize
+ if( *filesize == 0 ){
+ perror("Error file size for reading");
+ exit(EXIT_FAILURE);
+ }
+
+ // Trim the file name.
+ fncopy = strndup(filename, *length);
+ blank = strchr(fncopy, ' ');
+ if (blank != NULL) {
+ fncopy[blank - fncopy] = '\0';
+ }
+
+ // opens file
+ ft = fopen( fncopy, "r+" );
+ if( ft == NULL ) { perror("fopen"); exit(-1); }
+
+ // sets mode for full buffering
+ work_buffer[*fid] = (char *)malloc(MAX_B);
+ setvbuf( ft, work_buffer[*fid], _IOFBF, (size_t)MAX_B );
+
+ // stores file index id fid: from 0 to 8
+ fp_abs[*fid] = ft;
+
+ free(fncopy);
+}
+
+//void
+//FC_FUNC_(open_file_abs_w_fbin,OPEN_FILE_ABS_W_FBIN)(int *fid, char *filename, int *length, int *filesize){
+void open_file_abs_w_fbin(int *fid, char *filename, int *length, int *filesize){
+
+// opens file for write access
+
+ //This sequence assigns the MAX_B array work_buffer to the file pointer
+ // to be used for its buffering. performance should benefit.
+ char * fncopy;
+ char * blank;
+ FILE *ft;
+
+ // checks filesize
+ if( *filesize == 0 ){
+ perror("Error file size for reading");
+ exit(EXIT_FAILURE);
+ }
+
+ // Trim the file name.
+ fncopy = strndup(filename, *length);
+ blank = strchr(fncopy, ' ');
+ if (blank != NULL) {
+ fncopy[blank - fncopy] = '\0';
+ }
+
+ // opens file
+ ft = fopen( fncopy, "w+" );
+ if( ft == NULL ) { perror("fopen"); exit(-1); }
+
+ // sets mode for full buffering
+ work_buffer[*fid] = (char *)malloc(MAX_B);
+ setvbuf( ft, work_buffer[*fid], _IOFBF, (size_t)MAX_B );
+
+ // stores file index id fid: from 0 to 8
+ fp_abs[*fid] = ft;
+
+ free(fncopy);
+
+}
+
+//void
+//FC_FUNC_(close_file_abs_fbin,CLOSE_FILE_ABS_FBIN)(int * fid){
+void close_file_abs_fbin(int * fid){
+
+// closes file
+
+ fclose(fp_abs[*fid]);
+
+ free(work_buffer[*fid]);
+
+}
+
+//void
+//FC_FUNC_(write_abs_fbin,WRITE_ABS_FBIN)(int *fid, void *buffer, int *length, int *index){
+void write_abs_fbin(int *fid, void *buffer, int *length, int *index){
+
+// writes binary file data in chunks of MAX_B
+
+ FILE *ft;
+ int itemlen,remlen,donelen,ret;
+ void *buf;
+
+ // file pointer
+ ft = fp_abs[*fid];
+
+ donelen = 0;
+ remlen = *length;
+ buf = buffer;
+ ret = 0;
+
+ //float dat[2];
+ //memcpy(dat,buffer,*length);
+ //printf("buffer: %f %f\n",dat[0],dat[1]);
+
+ // writes items of maximum MAX_B to the file
+ while (remlen > 0){
+
+ itemlen = MIN(remlen,MAX_B);
+ ret = fwrite(buf,1,itemlen,ft);
+ if (ret > 0){
+ donelen = donelen + ret;
+ remlen = remlen - MAX_B;
+ buf += MAX_B;
+ }
+ else{
+ remlen = 0;
+ }
+ }
+
+}
+
+//void
+//FC_FUNC_(read_abs_fbin,READ_ABS_FBIN)(int *fid, void *buffer, int *length, int *index){
+void read_abs_fbin(int *fid, void *buffer, int *length, int *index){
+
+// reads binary file data in chunks of MAX_B
+
+ FILE *ft;
+ int ret,itemlen,remlen,donelen,pos;
+ void *buf;
+
+ // file pointer
+ ft = fp_abs[*fid];
+
+ // positions file pointer (for reverse time access)
+ pos = (*length) * (*index -1 );
+ fseek(ft, pos , SEEK_SET);
+
+ donelen = 0;
+ remlen = *length;
+ buf = buffer;
+ ret = 0;
+
+ // reads items of maximum MAX_B to the file
+ while (remlen > 0){
+
+ // checks end of file
+ if (ferror(ft) || feof(ft)) return;
+
+ itemlen = MIN(remlen,MAX_B);
+ ret = fread(buf,1,itemlen,ft);
+
+ if (ferror(ft) || feof(ft)) return;
+
+ if (ret > 0){
+ donelen = donelen + ret;
+ remlen = remlen - MAX_B;
+ buf += MAX_B;
+ }
+ else{
+ remlen = 0;
+ }
+ }
+
+ //float dat[2];
+ //memcpy(dat,buffer,*length);
+ //printf("return buffer: %f %f\n",dat[0],dat[1]);
+}
+
+
+
+
+/* ---------------------------------------
+
+ IO performance test
+
+
+A Performance Comparison of "read" and "mmap" in the Solaris 8 OS
+
+By Oyetunde Fadele, September 2002
+
+http://developers.sun.com/solaris/articles/read_mmap.html
+
+or
+
+High-performance network programming, Part 2: Speed up processing at both the client and server
+
+by Girish Venkatachalam
+
+http://www.ibm.com/developerworks/aix/library/au-highperform2/
+
+
+ - uses functions mmap/memcpy for mapping file I/O
+
+------------------------------------- */
+
+
+#include <errno.h>
+#include <limits.h>
+#include <sys/mman.h>
+
+// file maps
+static char * map_abs[ABS_FILEID];
+// file descriptors
+static int map_fd_abs[ABS_FILEID];
+// file sizes
+static int filesize_abs[ABS_FILEID];
+
+//void
+//FC_FUNC_(open_file_abs_w_map,OPEN_FILE_ABS_W_MAP)(int *fid, char *filename, int *length, int *filesize){
+void open_file_abs_w_map(int *fid, char *filename, int *length, int *filesize){
+
+// opens file for write access
+
+ int ft;
+ int result;
+ char *map;
+ char *fncopy;
+ char *blank;
+
+ // checks filesize
+ if( *filesize == 0 ){
+ perror("Error file size for writing");
+ exit(EXIT_FAILURE);
+ }
+
+ // Trim the file name.
+ fncopy = strndup(filename, *length);
+ blank = strchr(fncopy, ' ');
+ if (blank != NULL) {
+ fncopy[blank - fncopy] = '\0';
+ }
+
+ /* Open a file for writing.
+ * - Creating the file if it doesn't exist.
+ * - Truncating it to 0 size if it already exists. (not really needed)
+ *
+ * Note: "O_WRONLY" mode is not sufficient when mmaping.
+ */
+ ft = open(fncopy, O_RDWR | O_CREAT | O_TRUNC, (mode_t)0600);
+ if (ft == -1) {
+ perror("Error opening file for writing");
+ exit(EXIT_FAILURE);
+ }
+
+ // file index id fid: from 0 to 8
+ map_fd_abs[*fid] = ft;
+
+ free(fncopy);
+
+
+ /* Stretch the file size to the size of the (mmapped) array of ints
+ */
+ filesize_abs[*fid] = *filesize;
+ result = lseek(ft, filesize_abs[*fid] - 1, SEEK_SET);
+ if (result == -1) {
+ close(ft);
+ perror("Error calling fseek() to 'stretch' the file");
+ exit(EXIT_FAILURE);
+ }
+
+ //printf("file length: %d \n",filesize_abs[*fid]);
+
+
+ /* Something needs to be written at the end of the file to
+ * have the file actually have the new size.
+ * Just writing an empty string at the current file position will do.
+ *
+ * Note:
+ * - The current position in the file is at the end of the stretched
+ * file due to the call to lseek().
+ * - An empty string is actually a single '\0' character, so a zero-byte
+ * will be written at the last byte of the file.
+ */
+ result = write(ft, "", 1);
+ if (result != 1) {
+ close(ft);
+ perror("Error writing last byte of the file");
+ exit(EXIT_FAILURE);
+ }
+
+ /* Now the file is ready to be mmapped.
+ */
+ map = mmap(0, filesize_abs[*fid], PROT_READ | PROT_WRITE, MAP_SHARED, ft, 0);
+ if (map == MAP_FAILED) {
+ close(ft);
+ perror("Error mmapping the file");
+ exit(EXIT_FAILURE);
+ }
+
+ map_abs[*fid] = map;
+
+ //printf("file map: %d\n",*fid);
+
+}
+
+//void
+//FC_FUNC_(open_file_abs_r_map,OPEN_FILE_ABS_R_MAP)(int *fid, char *filename,int *length, int *filesize){
+void open_file_abs_r_map(int *fid, char *filename,int *length, int *filesize){
+
+ // opens file for read access
+ char * fncopy;
+ char * blank;
+ int ft;
+ char *map;
+
+ // checks filesize
+ if( *filesize == 0 ){
+ perror("Error file size for reading");
+ exit(EXIT_FAILURE);
+ }
+
+ // Trim the file name.
+ fncopy = strndup(filename, *length);
+ blank = strchr(fncopy, ' ');
+ if (blank != NULL) {
+ fncopy[blank - fncopy] = '\0';
+ }
+
+
+ ft = open(fncopy, O_RDONLY);
+ if (ft == -1) {
+ perror("Error opening file for reading");
+ exit(EXIT_FAILURE);
+ }
+
+ // file index id fid: from 0 to 8
+ map_fd_abs[*fid] = ft;
+
+ free(fncopy);
+
+ filesize_abs[*fid] = *filesize;
+
+ map = mmap(0, filesize_abs[*fid], PROT_READ, MAP_SHARED, ft, 0);
+ if (map == MAP_FAILED) {
+ close(ft);
+ perror("Error mmapping the file");
+ exit(EXIT_FAILURE);
+ }
+
+ map_abs[*fid] = map;
+
+ //printf("file length r: %d \n",filesize_abs[*fid]);
+ //printf("file map r: %d\n",*fid);
+
+}
+
+
+//void
+//FC_FUNC_(close_file_abs_map,CLOSE_FILE_ABS_MAP)(int * fid){
+void close_file_abs_map(int * fid){
+
+ /* Don't forget to free the mmapped memory
+ */
+ if (munmap(map_abs[*fid], filesize_abs[*fid]) == -1) {
+ perror("Error un-mmapping the file");
+ /* Decide here whether to close(fd) and exit() or not. Depends... */
+ }
+
+ /* Un-mmaping doesn't close the file, so we still need to do that.
+ */
+ close(map_fd_abs[*fid]);
+}
+
+
+//void
+//FC_FUNC_(write_abs_map,WRITE_ABS_MAP)(int *fid, char *buffer, int *length , int *index){
+void write_abs_map(int *fid, char *buffer, int *length , int *index){
+
+ char *map;
+ int offset;
+
+ map = map_abs[*fid];
+
+ // offset in bytes
+ offset = (*index -1 ) * (*length) ;
+
+ // copies buffer to map
+ memcpy( &map[offset], buffer ,*length );
+
+}
+
+//void
+//FC_FUNC_(read_abs_map,READ_ABS_MAP)(int *fid, char *buffer, int *length , int *index){
+void read_abs_map(int *fid, char *buffer, int *length , int *index){
+
+ char *map;
+ int offset;
+
+ map = map_abs[*fid];
+
+ // offset in bytes
+ offset = (*index -1 ) * (*length) ;
+
+ // copies map to buffer
+ memcpy( buffer, &map[offset], *length );
+
+}
+
+
+/*
+
+wrapper functions
+
+- for your preferred, optimized file i/o ;
+ e.g. uncomment // #define USE_MAP... in config.h to use mmap routines
+ or comment out (default) to use fopen/fwrite/fread functions
+
+ note: mmap functions should work fine for local harddisk directories, but can lead to
+ problems with global (e.g. NFS) directories
+
+ (on nehalem, Linux 2.6.18-164.11.1.el5 #1 SMP Wed Jan 20 10:04:55 EST 2010 x86_64 x86_64 x86_64 GNU/Linux
+ - mmap functions are about 20 % faster than conventional fortran, unformatted file i/o
+ - fwrite/fread function are about 12 % faster than conventional fortran, unformatted file i/o )
+
+*/
+
+void
+FC_FUNC_(open_file_abs_w,OPEN_FILE_ABS_W)(int *fid, char *filename,int *length, int *filesize) {
+
+#ifdef USE_MAP_FUNCTION
+ open_file_abs_w_map(fid,filename,length,filesize);
+#else
+ open_file_abs_w_fbin(fid,filename,length,filesize);
+#endif
+
+}
+
+void
+FC_FUNC_(open_file_abs_r,OPEN_FILE_ABS_R)(int *fid, char *filename,int *length, int *filesize) {
+
+#ifdef USE_MAP_FUNCTION
+ open_file_abs_r_map(fid,filename,length,filesize);
+#else
+ open_file_abs_r_fbin(fid,filename,length,filesize);
+#endif
+
+}
+
+void
+FC_FUNC_(close_file_abs,CLOSE_FILES_ABS)(int *fid) {
+
+#ifdef USE_MAP_FUNCTION
+ close_file_abs_map(fid);
+#else
+ close_file_abs_fbin(fid);
+#endif
+
+}
+
+void
+FC_FUNC_(write_abs,WRITE_ABS)(int *fid, char *buffer, int *length , int *index) {
+
+#ifdef USE_MAP_FUNCTION
+ write_abs_map(fid,buffer,length,index);
+#else
+ write_abs_fbin(fid,buffer,length,index);
+#endif
+
+}
+
+void
+FC_FUNC_(read_abs,READ_ABS)(int *fid, char *buffer, int *length , int *index) {
+
+#ifdef USE_MAP_FUNCTION
+ read_abs_map(fid,buffer,length,index);
+#else
+ read_abs_fbin(fid,buffer,length,index);
+#endif
+
+}
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_movie_surface.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_surface.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_movie_surface.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_movie_surface.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,123 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_x_all,store_val_y_all,store_val_z_all, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ store_val_ux_all,store_val_uy_all,store_val_uz_all, &
+ ibelm_top_crust_mantle,ibool_crust_mantle,nspec_top, &
+ NIT,it,OUTPUT_FILES)
+
+ implicit none
+
+ include 'mpif.h'
+ include "precision.h"
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank,nmovie_points
+ double precision :: scale_veloc
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ veloc_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(nmovie_points) :: &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_ux,store_val_uy,store_val_uz
+
+ real(kind=CUSTOM_REAL), dimension(nmovie_points,0:NPROCTOT_VAL-1) :: &
+ store_val_x_all,store_val_y_all,store_val_z_all, &
+ store_val_ux_all,store_val_uy_all,store_val_uz_all
+
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ integer nspec_top,NIT,it
+ character(len=150) OUTPUT_FILES
+
+ ! local parameters
+ character(len=150) :: outputname
+ integer :: ipoin,ispec2D,ispec,i,j,k,ier,iglob
+
+ ! save velocity here to avoid static offset on displacement for movies
+
+
+ ! get coordinates of surface mesh and surface displacement
+ ipoin = 0
+ do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ ispec = ibelm_top_crust_mantle(ispec2D)
+
+ ! in case of global, NCHUNKS_VAL == 6 simulations, be aware that for
+ ! the cubed sphere, the mapping changes for different chunks,
+ ! i.e. e.g. x(1,1) and x(5,5) flip left and right sides of the elements in geographical coordinates.
+ ! for future consideration, like in create_movie_GMT_global.f90 ...
+ k = NGLLZ
+
+ ! loop on all the points inside the element
+ do j = 1,NGLLY,NIT
+ do i = 1,NGLLX,NIT
+ ipoin = ipoin + 1
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+ store_val_x(ipoin) = xstore_crust_mantle(iglob)
+ store_val_y(ipoin) = ystore_crust_mantle(iglob)
+ store_val_z(ipoin) = zstore_crust_mantle(iglob)
+ store_val_ux(ipoin) = veloc_crust_mantle(1,iglob)*scale_veloc
+ store_val_uy(ipoin) = veloc_crust_mantle(2,iglob)*scale_veloc
+ store_val_uz(ipoin) = veloc_crust_mantle(3,iglob)*scale_veloc
+ enddo
+ enddo
+
+ enddo
+
+ ! gather info on master proc
+ ispec = nmovie_points
+ call MPI_GATHER(store_val_x,ispec,CUSTOM_MPI_TYPE,store_val_x_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(store_val_y,ispec,CUSTOM_MPI_TYPE,store_val_y_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(store_val_z,ispec,CUSTOM_MPI_TYPE,store_val_z_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(store_val_ux,ispec,CUSTOM_MPI_TYPE,store_val_ux_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(store_val_uy,ispec,CUSTOM_MPI_TYPE,store_val_uy_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(store_val_uz,ispec,CUSTOM_MPI_TYPE,store_val_uz_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+
+ ! save movie data to disk in home directory
+ if(myrank == 0) then
+ write(outputname,"('/moviedata',i6.6)") it
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted',action='write')
+ write(IOUT) store_val_x_all
+ write(IOUT) store_val_y_all
+ write(IOUT) store_val_z_all
+ write(IOUT) store_val_ux_all
+ write(IOUT) store_val_uy_all
+ write(IOUT) store_val_uz_all
+ close(IOUT)
+ endif
+
+ end subroutine write_movie_surface
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_movie_volume.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_volume.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_movie_volume.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_movie_volume.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,543 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create file OUTPUT_FILES/values_from_mesher.h based upon DATA/Par_file
+! in order to compile the solver with the right array sizes
+
+!---------------------------------------------------------------------------------
+! this subroutine counts the number of points and elements within the movie volume
+! in this processor slice, and returns arrays that keep track of them, both in global and local indexing schemes
+
+ subroutine count_points_movie_volume(prname,ibool_crust_mantle, xstore_crust_mantle,ystore_crust_mantle, &
+ zstore_crust_mantle,MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ MOVIE_COARSE,npoints_3dmovie,nspecel_3dmovie,num_ibool_3dmovie, &
+ mask_ibool_3dmovie,mask_3dmovie)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+! input
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+ double precision :: MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
+ logical :: MOVIE_COARSE
+ character(len=150) :: prname
+
+! output
+ integer :: npoints_3dmovie,nspecel_3dmovie
+ integer, dimension(NGLOB_CRUST_MANTLE) :: num_ibool_3dmovie
+ logical, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool_3dmovie
+ logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
+
+! variables
+ integer :: ipoints_3dmovie,ispecel_3dmovie,ispec,iglob,i,j,k,NIT
+ real(kind=custom_real) :: rval,thetaval,phival
+
+ if(MOVIE_COARSE) then
+ NIT = NGLLX-1
+ else
+ NIT = 1
+ endif
+ ipoints_3dmovie=0
+ num_ibool_3dmovie(:) = -99
+ ispecel_3dmovie = 0
+ mask_ibool_3dmovie(:)=.false.
+ mask_3dmovie(:,:,:,:)=.false.
+ ! create name of database
+ open(unit=IOUT,file=trim(prname)//'movie3D_info.txt',status='unknown')
+
+ !find and count points within given region for storing movie
+ do ispec = 1,NSPEC_CRUST_MANTLE
+ !output element if center of element is in the given region
+ iglob = ibool_crust_mantle((NGLLX+1)/2,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ rval = xstore_crust_mantle(iglob)
+ thetaval = ystore_crust_mantle(iglob)
+ phival = zstore_crust_mantle(iglob)
+ ! we alread changed xyz back to rthetaphi
+ if( (rval < MOVIE_TOP .and. rval > MOVIE_BOTTOM) .and. &
+ (thetaval > MOVIE_NORTH .and. thetaval < MOVIE_SOUTH) .and. &
+ ( (phival < MOVIE_EAST .and. phival > MOVIE_WEST) .or. &
+ ( (MOVIE_EAST < MOVIE_WEST) .and. (phival >MOVIE_EAST .or. phival < MOVIE_WEST) ) ) ) then
+ ispecel_3dmovie=ispecel_3dmovie+1
+ do k=1,NGLLZ,NIT
+ do j=1,NGLLY,NIT
+ do i=1,NGLLX,NIT
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+ if(.not. mask_ibool_3dmovie(iglob)) then
+ ipoints_3dmovie = ipoints_3dmovie + 1
+ mask_ibool_3dmovie(iglob)=.true.
+ mask_3dmovie(i,j,k,ispec)=.true.
+ num_ibool_3dmovie(iglob)= ipoints_3dmovie
+ endif
+ enddo !i
+ enddo !j
+ enddo !k
+ endif !in region
+ enddo !ispec
+ npoints_3dmovie=ipoints_3dmovie
+ nspecel_3dmovie=ispecel_3dmovie
+
+ write(IOUT,*) npoints_3dmovie, nspecel_3dmovie
+ close(IOUT)
+
+ end subroutine count_points_movie_volume
+
+! -----------------------------------------------------------------
+! writes meshfiles to merge with solver snapshots for 3D volume movies. Also computes and outputs
+! the rotation matrix nu_3dmovie required to transfer to a geographic coordinate system
+
+ subroutine write_movie_volume_mesh(npoints_3dmovie,prname,ibool_crust_mantle,xstore_crust_mantle, &
+ ystore_crust_mantle,zstore_crust_mantle, muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,mask_ibool_3dmovie,num_ibool_3dmovie,nu_3dmovie,MOVIE_COARSE)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ !input
+ integer :: npoints_3dmovie
+ integer, dimension(NGLOB_CRUST_MANTLE) :: num_ibool_3dmovie
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: muvstore_crust_mantle_3dmovie
+ character(len=150) :: prname
+ logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
+ logical, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool_3dmovie
+ logical :: MOVIE_COARSE
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ !output
+ real(kind=CUSTOM_REAL), dimension(3,3,npoints_3dmovie) :: nu_3dmovie
+ real(kind=CUSTOM_REAL), dimension(npoints_3dmovie) :: store_val3D_mu
+
+ !variables
+ integer :: ipoints_3dmovie,ispecele,ispec,i,j,k,iglob,iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
+ integer :: n1,n2,n3,n4,n5,n6,n7,n8,NIT
+ real(kind=CUSTOM_REAL) :: rval,thetaval,phival,xval,yval,zval,st,ct,sp,cp
+ real(kind=CUSTOM_REAL), dimension(npoints_3dmovie) :: store_val3D_x,store_val3D_y, store_val3D_z
+
+ if(NDIM /= 3) stop 'movie volume output requires NDIM = 3'
+
+ if(MOVIE_COARSE) then
+ NIT = NGLLX-1
+ else
+ NIT = 1
+ endif
+
+ ipoints_3dmovie=0
+ do ispec=1,NSPEC_CRUST_MANTLE
+ do k=1,NGLLZ,NIT
+ do j=1,NGLLY,NIT
+ do i=1,NGLLX,NIT
+ if(mask_3dmovie(i,j,k,ispec)) then
+ ipoints_3dmovie=ipoints_3dmovie+1
+ iglob= ibool_crust_mantle(i,j,k,ispec)
+ rval = xstore_crust_mantle(iglob)
+ thetaval = ystore_crust_mantle(iglob)
+ phival = zstore_crust_mantle(iglob)
+!x,y,z store have been converted to r theta phi already, need to revert back for xyz output
+ call rthetaphi_2_xyz(xval,yval,zval,rval,thetaval,phival)
+ store_val3D_x(ipoints_3dmovie)=xval
+ store_val3D_y(ipoints_3dmovie)=yval
+ store_val3D_z(ipoints_3dmovie)=zval
+ store_val3D_mu(ipoints_3dmovie)=muvstore_crust_mantle_3dmovie(i,j,k,ispec)
+ st = sin(thetaval)
+ ct = cos(thetaval)
+ sp = sin(phival)
+ cp = cos(phival)
+ nu_3dmovie(1,1,ipoints_3dmovie)=-ct*cp
+ nu_3dmovie(1,2,ipoints_3dmovie)=-ct*sp
+ nu_3dmovie(1,3,ipoints_3dmovie)=st
+ nu_3dmovie(2,1,ipoints_3dmovie)=-sp
+ nu_3dmovie(2,2,ipoints_3dmovie)=cp
+ nu_3dmovie(2,3,ipoints_3dmovie)=0.d0
+ nu_3dmovie(3,1,ipoints_3dmovie)=st*cp
+ nu_3dmovie(3,2,ipoints_3dmovie)=st*sp
+ nu_3dmovie(3,3,ipoints_3dmovie)=ct
+ endif !mask_3dmovie
+ enddo !i
+ enddo !j
+ enddo !k
+ enddo !ispec
+ open(unit=IOUT,file=trim(prname)//'movie3D_x.bin',status='unknown',form='unformatted')
+ if(npoints_3dmovie>0) then
+ write(IOUT) store_val3D_x(1:npoints_3dmovie)
+ endif
+ close(IOUT)
+ open(unit=IOUT,file=trim(prname)//'movie3D_y.bin',status='unknown',form='unformatted')
+ if(npoints_3dmovie>0) then
+ write(IOUT) store_val3D_y(1:npoints_3dmovie)
+ endif
+ close(IOUT)
+
+ open(unit=IOUT,file=trim(prname)//'movie3D_z.bin',status='unknown',form='unformatted')
+ if(npoints_3dmovie>0) then
+ write(IOUT) store_val3D_z(1:npoints_3dmovie)
+ endif
+ close(IOUT)
+
+ open(unit=IOUT,file=trim(prname)//'ascii_output.txt',status='unknown')
+ if(npoints_3dmovie>0) then
+ do i=1,npoints_3dmovie
+ write(IOUT,*) store_val3D_x(i),store_val3D_y(i),store_val3D_z(i),store_val3D_mu(i)
+ enddo
+ endif
+ close(IOUT)
+ open(unit=IOUT,file=trim(prname)//'movie3D_elements.bin',status='unknown',form='unformatted')
+ ispecele=0
+ ! open(unit=IOUT,file=trim(prname)//'movie3D_elements.txt',status='unknown')
+ do ispec=1,NSPEC_CRUST_MANTLE
+ if(MOVIE_COARSE) then
+ iglob=ibool_crust_mantle(1,1,1,ispec)
+ else
+ iglob=ibool_crust_mantle(3,3,3,ispec)
+ endif
+ if(mask_ibool_3dmovie(iglob)) then !this element is in the region
+ ispecele = ispecele+1
+ do k=1,NGLLZ-1,NIT
+ do j=1,NGLLY-1,NIT
+ do i=1,NGLLX-1,NIT
+ ! if(mask_3dmovie(i,j,k,ispec)) then
+ iglob1 = ibool_crust_mantle(i,j,k,ispec)
+ iglob2 = ibool_crust_mantle(i+NIT,j,k,ispec)
+ iglob3 = ibool_crust_mantle(i+NIT,j+NIT,k,ispec)
+ iglob4 = ibool_crust_mantle(i,j+NIT,k,ispec)
+ iglob5 = ibool_crust_mantle(i,j,k+NIT,ispec)
+ iglob6 = ibool_crust_mantle(i+NIT,j,k+NIT,ispec)
+ iglob7 = ibool_crust_mantle(i+NIT,j+NIT,k+NIT,ispec)
+ iglob8 = ibool_crust_mantle(i,j+NIT,k+NIT,ispec)
+ n1 = num_ibool_3dmovie(iglob1)-1
+ n2 = num_ibool_3dmovie(iglob2)-1
+ n3 = num_ibool_3dmovie(iglob3)-1
+ n4 = num_ibool_3dmovie(iglob4)-1
+ n5 = num_ibool_3dmovie(iglob5)-1
+ n6 = num_ibool_3dmovie(iglob6)-1
+ n7 = num_ibool_3dmovie(iglob7)-1
+ n8 = num_ibool_3dmovie(iglob8)-1
+ write(IOUT) n1,n2,n3,n4,n5,n6,n7,n8
+ ! write(57,*) n1,n2,n3,n4,n5,n6,n7,n8
+ ! endif !mask3dmovie
+ enddo !i
+ enddo !j
+ enddo !k
+ endif
+ enddo !ispec
+ close(IOUT)
+! close(57)
+ end subroutine write_movie_volume_mesh
+
+! ---------------------------------------------
+
+ subroutine write_movie_volume_strains(myrank,npoints_3dmovie,LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle,muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie)
+
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ ! input
+ integer :: myrank,npoints_3dmovie,MOVIE_VOLUME_TYPE,it
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: eps_trace_over_3_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: muvstore_crust_mantle_3dmovie
+ logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
+ logical :: MOVIE_COARSE
+ real(kind=CUSTOM_REAL), dimension(3,3,npoints_3dmovie) :: nu_3dmovie
+ character(len=150) LOCAL_PATH,outputname
+
+ ! variables
+ character(len=150) prname
+ integer :: ipoints_3dmovie,i,j,k,ispec,NIT
+ real(kind=CUSTOM_REAL) :: muv_3dmovie
+ real(kind=CUSTOM_REAL),dimension(3,3) :: eps_loc,eps_loc_new
+ real(kind=CUSTOM_REAL),dimension(:),allocatable :: store_val3d_NN,store_val3d_EE,store_val3d_ZZ,&
+ store_val3d_NE,store_val3d_NZ,store_val3d_EZ
+
+ character(len=1) movie_prefix
+
+ allocate(store_val3d_NN(npoints_3dmovie))
+ allocate(store_val3d_EE(npoints_3dmovie))
+ allocate(store_val3d_ZZ(npoints_3dmovie))
+ allocate(store_val3d_NE(npoints_3dmovie))
+ allocate(store_val3d_NZ(npoints_3dmovie))
+ allocate(store_val3d_EZ(npoints_3dmovie))
+
+ if(NDIM /= 3) call exit_MPI(myrank, 'write_movie_volume requires NDIM = 3')
+
+ if(MOVIE_VOLUME_TYPE == 1) then
+ movie_prefix='E' ! strain
+ else if(MOVIE_VOLUME_TYPE == 2) then
+ movie_prefix='S' ! time integral of strain
+ else if(MOVIE_VOLUME_TYPE == 3) then
+ movie_prefix='P' ! potency, or integral of strain x \mu
+ endif
+ if(MOVIE_COARSE) then
+ NIT = NGLLX-1
+ else
+ NIT = 1
+ endif
+
+ write(prname,"('proc',i6.6)") myrank
+ ipoints_3dmovie=0
+ do ispec=1,NSPEC_CRUST_MANTLE
+ do k=1,NGLLZ,NIT
+ do j=1,NGLLY,NIT
+ do i=1,NGLLX,NIT
+ if(mask_3dmovie(i,j,k,ispec)) then
+ ipoints_3dmovie=ipoints_3dmovie+1
+ muv_3dmovie=muvstore_crust_mantle_3dmovie(i,j,k,ispec)
+ eps_loc(1,1)=eps_trace_over_3_crust_mantle(i,j,k,ispec) + epsilondev_crust_mantle(1,i,j,k,ispec)
+ eps_loc(2,2)=eps_trace_over_3_crust_mantle(i,j,k,ispec) + epsilondev_crust_mantle(2,i,j,k,ispec)
+ eps_loc(3,3)=eps_trace_over_3_crust_mantle(i,j,k,ispec)- &
+ epsilondev_crust_mantle(1,i,j,k,ispec) - epsilondev_crust_mantle(2,i,j,k,ispec)
+ eps_loc(1,2)=epsilondev_crust_mantle(3,i,j,k,ispec)
+ eps_loc(1,3)=epsilondev_crust_mantle(4,i,j,k,ispec)
+ eps_loc(2,3)=epsilondev_crust_mantle(5,i,j,k,ispec)
+ eps_loc(2,1)=eps_loc(1,2)
+ eps_loc(3,1)=eps_loc(1,3)
+ eps_loc(3,2)=eps_loc(2,3)
+
+ ! rotate eps_loc to spherical coordinates
+ eps_loc_new(:,:) = matmul(matmul(nu_3dmovie(:,:,ipoints_3dmovie),eps_loc(:,:)), transpose(nu_3dmovie(:,:,ipoints_3dmovie)))
+ if(MOVIE_VOLUME_TYPE == 3) eps_loc_new(:,:) = eps_loc(:,:)*muv_3dmovie
+ store_val3d_NN(ipoints_3dmovie)=eps_loc_new(1,1)
+ store_val3d_EE(ipoints_3dmovie)=eps_loc_new(2,2)
+ store_val3d_ZZ(ipoints_3dmovie)=eps_loc_new(3,3)
+ store_val3d_NE(ipoints_3dmovie)=eps_loc_new(1,2)
+ store_val3d_NZ(ipoints_3dmovie)=eps_loc_new(1,3)
+ store_val3d_EZ(ipoints_3dmovie)=eps_loc_new(2,3)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ if(ipoints_3dmovie /= npoints_3dmovie) stop 'did not find the right number of points for 3D movie'
+
+ write(outputname,"('proc',i6.6,'_movie3D_',a,'NN',i6.6,'.bin')") myrank,movie_prefix,it
+ open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
+ write(27) store_val3d_NN(1:npoints_3dmovie)
+ close(27)
+
+ write(outputname,"('proc',i6.6,'_movie3D_',a,'EE',i6.6,'.bin')") myrank,movie_prefix,it
+ open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
+ write(27) store_val3d_EE(1:npoints_3dmovie)
+ close(27)
+
+ write(outputname,"('proc',i6.6,'_movie3D_',a,'ZZ',i6.6,'.bin')") myrank,movie_prefix,it
+ open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
+ write(27) store_val3d_ZZ(1:npoints_3dmovie)
+ close(27)
+
+ write(outputname,"('proc',i6.6,'_movie3D_',a,'NE',i6.6,'.bin')") myrank,movie_prefix,it
+ open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
+ write(27) store_val3d_NE(1:npoints_3dmovie)
+ close(27)
+
+
+ write(outputname,"('proc',i6.6,'_movie3D_',a,'NZ',i6.6,'.bin')") myrank,movie_prefix,it
+ open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
+ write(27) store_val3d_NZ(1:npoints_3dmovie)
+ close(27)
+
+ write(outputname,"('proc',i6.6,'_movie3D_',a,'EZ',i6.6,'.bin')") myrank,movie_prefix,it
+ open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
+ write(27) store_val3d_EZ(1:npoints_3dmovie)
+ close(27)
+
+ end subroutine write_movie_volume_strains
+
+! ---------------------------------------------
+ subroutine write_movie_volume_vector(myrank,it,npoints_3dmovie,LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,vector_crust_mantle,scalingval,mask_3dmovie,nu_3dmovie)
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ ! input
+ integer :: myrank,npoints_3dmovie,MOVIE_VOLUME_TYPE,it
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(3,NGLOB_CRUST_MANTLE) :: vector_crust_mantle,vector_scaled
+ real(kind=CUSTOM_REAL), dimension(3,3,npoints_3dmovie) :: nu_3dmovie
+ double precision :: scalingval
+ real(kind=CUSTOM_REAL), dimension(3) :: vector_local,vector_local_new
+ logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
+ logical :: MOVIE_COARSE
+ character(len=150) LOCAL_PATH
+
+ ! variables
+ integer :: ipoints_3dmovie,i,j,k,ispec,NIT,iglob
+ real(kind=CUSTOM_REAL),dimension(:),allocatable :: store_val3d_N,store_val3d_E,store_val3d_Z
+ character(len=150) outputname
+ character(len=2) movie_prefix
+
+ if(NDIM /= 3) call exit_MPI(myrank,'write_movie_volume requires NDIM = 3')
+
+ allocate(store_val3d_N(npoints_3dmovie))
+ allocate(store_val3d_E(npoints_3dmovie))
+ allocate(store_val3d_Z(npoints_3dmovie))
+
+ if(MOVIE_VOLUME_TYPE == 5) then
+ movie_prefix='DI' ! displacement
+ else if(MOVIE_VOLUME_TYPE == 6) then
+ movie_prefix='VE' ! velocity
+ endif
+ if(MOVIE_COARSE) then
+ NIT = NGLLX-1
+ else
+ NIT = 1
+ endif
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ vector_scaled = vector_crust_mantle*sngl(scalingval)
+ else
+ vector_scaled = vector_crust_mantle*scalingval
+ endif
+
+ ipoints_3dmovie=0
+ do ispec=1,NSPEC_CRUST_MANTLE
+ do k=1,NGLLZ,NIT
+ do j=1,NGLLY,NIT
+ do i=1,NGLLX,NIT
+ if(mask_3dmovie(i,j,k,ispec)) then
+ ipoints_3dmovie=ipoints_3dmovie+1
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+ vector_local(:) = vector_scaled(:,iglob)
+
+ ! rotate eps_loc to spherical coordinates
+ vector_local_new(:) = matmul(nu_3dmovie(:,:,ipoints_3dmovie), vector_local(:))
+ store_val3d_N(ipoints_3dmovie)=vector_local_new(1)
+ store_val3d_E(ipoints_3dmovie)=vector_local_new(2)
+ store_val3d_Z(ipoints_3dmovie)=vector_local_new(3)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ close(IOUT)
+ if(ipoints_3dmovie /= npoints_3dmovie) stop 'did not find the right number of points for 3D movie'
+
+ write(outputname,"('proc',i6.6,'_movie3D_',a,'N',i6.6,'.bin')") myrank,movie_prefix,it
+ open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
+ write(27) store_val3d_N(1:npoints_3dmovie)
+ close(27)
+
+ write(outputname,"('proc',i6.6,'_movie3D_',a,'E',i6.6,'.bin')") myrank,movie_prefix,it
+ open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
+ write(27) store_val3d_E(1:npoints_3dmovie)
+ close(27)
+
+ write(outputname,"('proc',i6.6,'_movie3D_',a,'Z',i6.6,'.bin')") myrank,movie_prefix,it
+ open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
+ write(27) store_val3d_Z(1:npoints_3dmovie)
+ close(27)
+
+
+ end subroutine write_movie_volume_vector
+
+!--------------------
+
+ subroutine write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
+ accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
+ eps_trace_over_3_inner_core,epsilondev_crust_mantle,&
+ epsilondev_inner_core)
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+ ! div
+ integer :: myrank,it,ispec,iglob,i,j,k
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: epsilondev_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STRAIN_ONLY) :: eps_trace_over_3_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: rhostore_outer_core, &
+ kappavstore_outer_core,ibool_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: accel_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: eps_trace_over_3_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev_crust_mantle
+ real(kind=CUSTOM_REAL) :: rhol,kappal
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: div_s_outer_core
+
+ character(len=150) LOCAL_PATH,outputname
+
+
+ write(outputname,"('proc',i6.6,'_crust_mantle_div_displ_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) eps_trace_over_3_crust_mantle
+ close(27)
+
+! we use div s = - p / kappa = rhostore_outer_core * accel_outer_core / kappavstore_outer_core
+ allocate(div_s_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT))
+ do ispec = 1, NSPEC_OUTER_CORE
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool_outer_core(i,j,k,ispec)
+ rhol = rhostore_outer_core(i,j,k,ispec)
+ kappal = kappavstore_outer_core(i,j,k,ispec)
+ div_s_outer_core(i,j,k,ispec) = rhol * accel_outer_core(iglob) / kappal
+ enddo
+ enddo
+ enddo
+ enddo
+
+ write(outputname,"('proc',i6.6,'_outer_core_div_displ_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) div_s_outer_core
+ close(27)
+
+ deallocate(div_s_outer_core)
+
+
+ ! write(outputname,"('proc',i6.6,'_outer_core_div_displ_it',i6.6,'.bin')") myrank,it
+ ! open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ ! write(27) ONE_THIRD * div_displ_outer_core
+ ! close(27)
+
+ write(outputname,"('proc',i6.6,'_inner_core_div_displ_proc_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) eps_trace_over_3_inner_core
+ close(27)
+
+! epsilondev
+
+ write(outputname,"('proc',i6.6,'_crust_mantle_epsdev_displ_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) epsilondev_crust_mantle
+ close(27)
+
+ write(outputname,"('proc',i6.6,'inner_core_epsdev_displ_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) epsilondev_inner_core
+ close(27)
+
+
+ end subroutine write_movie_volume_divcurl
+
+
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_output_ASCII.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/write_output_ASCII.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_output_ASCII.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_output_ASCII.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,111 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine write_output_ASCII(seismogram_tmp, &
+ DT,hdur,OUTPUT_FILES, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank, &
+ iorientation,sisname,sisname_big_file)
+
+! 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
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: seismo_offset, seismo_current, NTSTEP_BETWEEN_OUTPUT_SEISMOS
+
+ real(kind=CUSTOM_REAL), dimension(5,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: seismogram_tmp
+
+ integer myrank
+ double precision hdur,DT
+
+ integer iorientation
+
+ character(len=256) sisname,sisname_big_file
+ character(len=150) OUTPUT_FILES
+
+ ! 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
+
+ ! local parameters
+ integer ier,isample
+ character(len=256) sisname_2
+ double precision value
+
+
+ ! add .ascii extension to seismogram file name for ASCII seismograms
+ write(sisname_2,"('/',a,'.ascii')") trim(sisname)
+
+ ! create one large file instead of one small file per station to avoid file system overload
+ if(SAVE_ALL_SEISMOS_IN_ONE_FILE) then
+ if(USE_BINARY_FOR_LARGE_FILE) then
+ write(IOUT) sisname_big_file
+ else
+ write(IOUT,*) sisname_big_file(1:len_trim(sisname_big_file))
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2), &
+ status='unknown',action='write',iostat=ier)
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2), &
+ status='old',position='append',action='write',iostat=ier)
+ endif
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening file:'//trim(OUTPUT_FILES)//trim(sisname_2))
+ 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)
+
+ end subroutine write_output_ASCII
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_output_SAC.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/write_output_SAC.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_output_SAC.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_output_SAC.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,631 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine write_output_SAC(seismogram_tmp,irec, &
+ station_name,network_name,stlat,stlon,stele,stbur,nrec, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,tshift_cmt,t_shift,&
+ elat,elon,depth,event_name,cmt_lat,cmt_lon,cmt_depth,cmt_hdur, &
+ OUTPUT_FILES, &
+ OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
+ iorientation,phi,chn,sisname)
+
+! SAC headers have new format
+! by Ebru
+
+ implicit none
+
+ include "constants.h"
+
+ integer nrec,it_end
+
+ integer :: seismo_offset, seismo_current, NTSTEP_BETWEEN_OUTPUT_SEISMOS
+
+ real(kind=CUSTOM_REAL), dimension(5,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: seismogram_tmp
+
+ integer NEX_XI
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES
+
+ 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
+ integer iorientation
+
+ character(len=4) chn
+ character(len=256) sisname
+ character(len=150) OUTPUT_FILES
+
+ double precision tshift_cmt,t_shift,elat,elon,depth
+ double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
+ double precision, dimension(nrec) :: stlat,stlon,stele,stbur
+ integer yr,jda,ho,mi
+ double precision sec
+ character(len=20) event_name
+
+ ! flags to determine seismogram type
+ logical OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY
+
+ real(kind=CUSTOM_REAL) phi
+
+! local parameters
+ integer time_sec,isample
+ character(len=256) sisname_2
+ 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,USER4
+ 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(len=8) KSTNM
+ character(len=16) KEVNM
+ character(len=8) KCMPNM
+ character(len=8) KNETWK
+ character(len=8) KUSER0,KUSER1,KUSER2
+ character(len=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
+
+ double precision shortest_period
+ double precision value1,value2, value3,value4,value5
+ logical, external :: is_leap_year
+
+ !----------------------------------------------------------------
+
+!######################## 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. I 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 + tshift_cmt) ! [REQUIRED]
+ E = BYSAC ! [REQUIRED]
+ O = 0 !
+ A = undef !###
+ !station values:
+ STLA = stlat(irec)
+ STLO = stlon(irec)
+ STEL = stele(irec)
+ STDP = stbur(irec)
+
+ !event values (hypocenter):
+ ! note: this writes out the CMT location, which might be different
+ ! to the event location given in the first, PDE line
+ EVLA = cmt_lat
+ EVLO = cmt_lon
+ EVEL = undef !not defined
+ EVDP = cmt_depth
+
+
+ ! by Ebru
+ ! SAC headers will have new format
+ USER0 = cmt_hdur !half duration from CMT file if not changed to hdur=0.d0 (point source)
+
+ ! USER1 and USER2 slots are used for the shortest and longest periods at which
+ ! simulations are accurate, respectively.
+ shortest_period = (256/NEX_XI)*(ANGULAR_WIDTH_XI_IN_DEGREES/90)*17
+ USER1 = shortest_period
+ USER2 = 500.0d0
+ ! we remove any PDE information, since the simulation could also start
+ ! with a "pure" CMT solution, without having any PDE infos
+ !
+ !USER1 = t_shift !time shift between PDE and CMT solutions
+ !PDE location values (different from CMT location, usually):
+ !USER2 = depth !PDE depth
+ !USER3 = elat !PDE event latitude
+ !USER4 = elon !PDE event longitude
+ !
+ !cmt location values (different from hypocenter location, usually):
+ ! USER0 = cmt_lat
+ ! USER1 = cmt_lon
+ !USER0 = elat
+ !USER1 = elon
+ !USER2 = depth
+ !USER3 = cmt_hdur !half duration from CMT if not changed to hdur=0.d0 (point source)
+
+ ! just to avoid compiler warning
+ value1 = elat
+ value1 = elon
+ value1 = depth
+
+
+ ! it is not clear, which magnitude to write out:
+ ! should it be
+ ! body-wave-magnitude (Mb), surface-wave-magnitude (Ms), moment magnitude (Mw)
+ ! or leave magnitude and use scalar moment (M0, but calculated by which convention, Harvard?)
+ !
+ ! it's confusing, and as a result, we will omit it.
+ ! by Ebru
+ MAG = undef
+ IMAGTYP= undef
+
+ !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
+
+ ! adds time-shift to get the CMT time in the headers as origin time of events
+ ! by Ebru
+ NZSEC =int(sec+t_shift)
+ NZMSEC =int((sec+t_shift-int(sec+t_shift))*1000)
+
+ !NZSEC =int(sec)
+ !NZMSEC =int((sec-int(sec))*1000)
+
+ ! Adjust event time and date after t_shift is added
+ if (NZSEC >= 60) then
+ time_sec = jda*24*3600 + ho*3600 + mi*60 + int(sec+t_shift)
+ NZJDAY = int(time_sec/(24*3600))
+ NZHOUR = int(mod(time_sec,24*3600)/3600)
+ NZMIN = int(mod(time_sec,3600)/60)
+ NZSEC = mod(time_sec,60)
+ if (NZJDAY > 365 .and. .not. is_leap_year(NZYEAR)) then
+ NZJDAY = mod(NZJDAY,365)
+ NZYEAR = yr + 1
+ elseif (NZJDAY > 366 .and. is_leap_year(NZYEAR)) then
+ NZJDAY = mod(NZJDAY,366)
+ NZYEAR = yr + 1
+ elseif (NZJDAY == 366 .and. is_leap_year(NZYEAR)) then
+ NZJDAY = 366
+ endif
+ endif
+
+
+ NVHDR=6 ! SAC header version number. Current is 6
+
+ ! CSS3.0 variables:
+ NORID =int(undef) !origin ID
+ NEVID =int(undef) !event ID
+ !NWVID =undef !waveform ID
+
+ ! NUMBER of POINTS:
+ NPTS = it_end-seismo_offset ! [REQUIRED]
+ ! event type
+ IFTYPE = 1 ! 1=ITIME, i.e. seismogram [REQUIRED] # numbering system is
+ IDEP = 6 ! 6: displ/nm # quite strange, best
+
+ IZTYPE = 11 !=origint reference time equivalent ! # by chnhdr and write
+ IEVTYP = 40 !event type, 40: Earthquake # alpha and check
+ IQUAL = int(undef) ! quality
+ ISYNTH = int(undef) ! 1 real data, 2...n synth. flag
+ ! permission flags:
+ LEVEN =1 ! evenly spaced data [REQUIRED]
+ LPSPOL=1 ! ? pos. polarity of components (has to be TRUE for LCALDA=1)
+ LOVROK=1 ! 1: OK to overwrite file on disk
+ LCALDA=1 ! 1: calculate DIST, AZ, BAZ, and GCARC, 0: do nothing
+ ! ------------------end format 5I10---------
+ !
+ !----------------------------------
+ KSTNM = station_name(irec)(1:8) ! A8
+
+ ! writes out event id as event name
+ ! by Ebru
+ KEVNM = event_name(1:len_trim(event_name)) ! A16
+
+ !if (NSOURCES == 1) then
+ ! KEVNM = ename(1:len_trim(ename))//'_syn'! A16
+ !else
+ ! KEVNM = ename(1:len_trim(ename))//'_sFS'! A16
+ !endif
+
+ KCMPNM = chn(1:3) ! 3A8
+ KNETWK = network_name(irec) ! A6
+
+ ! indicates SEM synthetics
+ ! by Ebru
+ KUSER0 = 'SEM' ! A8
+ KUSER1 = 'v5.1.0'
+ KUSER2 = 'Tiger' ! aka. awesome (princeton) tiger version :)
+
+ !KUSER0 = 'PDE_LAT_' ! A8
+ !KUSER1 = 'PDE_LON_' ! A8
+ !KUSER2 = 'PDEDEPTH' ! A8
+ !----------------------------------
+
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM) then
+
+ ! add .sacan (sac alphanumeric) extension to seismogram file name for SAC seismograms
+ write(sisname_2,"('/',a,'.sacan')") trim(sisname)
+ if (seismo_offset == 0) then
+ open(unit=IOUT_SAC,file=trim(OUTPUT_FILES)//trim(sisname_2),&
+ status='unknown',action='write')
+ else
+ open(unit=IOUT_SAC,file=trim(OUTPUT_FILES)//trim(sisname_2),&
+ status='old', position='append',action='write')
+ endif
+
+! Formats of alphanumerical SAC header fields
+510 format(5G15.7,5G15.7,5G15.7,5G15.7,5G15.7)
+520 format(5I10,5I10,5I10,5I10,5I10)
+530 format(A8,A16)
+540 format(A8,A8,A8)
+
+
+ if (seismo_offset == 0) then
+ !
+ ! now write actual header:
+ ! ------------------------
+ !
+ ! real variables:
+ ! DELTA DEPMIN DEPMAX SCALE ODELTA
+ ! B E O A INTERNAL
+ ! T0 T1 T2 T3 T4
+ ! T5 T6 T7 T8 T9
+ ! F RESP0 RESP1 RESP2 RESP3
+ ! RESP4 RESP5 RESP6 RESP7 RESP8
+ ! RESP9 STLA STLO STEL STDP
+ ! EVLA EVLO EVEL EVDP MAG
+ ! USER0 USER1 USER2 USER3 USER4
+ ! USER5 USER6 USER7 USER8 USER9
+ ! DIST AZ BAZ GCARC INTERNAL
+ ! INTERNAL DEPMEN CMPAZ CMPINC XMINIMUM
+ ! XMAXIMUM YMINIMUM YMAXIMUM ADJTM UNUSED
+ !
+ write(IOUT_SAC,510) DELTA, DEPMIN, DEPMAX, SCALE_F, ODELTA
+ write(IOUT_SAC,510) B, E, O, A, INTERNAL
+ write(IOUT_SAC,510) undef, undef, undef, undef, undef
+ write(IOUT_SAC,510) undef, undef, undef, undef, undef
+ write(IOUT_SAC,510) undef, undef, undef, undef, undef
+ write(IOUT_SAC,510) undef, undef, undef, undef, undef
+ write(IOUT_SAC,510) undef, STLA, STLO, STEL, STDP
+ write(IOUT_SAC,510) EVLA, EVLO, EVEL, EVDP, MAG
+ write(IOUT_SAC,510) USER0, USER1, USER2, undef, undef
+ !write(IOUT_SAC,510) USER0, USER1, USER2, USER3, USER4
+ write(IOUT_SAC,510) undef, undef, undef, undef, undef
+ write(IOUT_SAC,510) DIST, AZ, BAZ, GCARC, INTERNAL
+ write(IOUT_SAC,510) INTERNAL, DEPMEN, CMPAZ, CMPINC, undef
+ write(IOUT_SAC,510) undef, undef, undef, undef, undef
+ write(IOUT_SAC,510) UNUSED, UNUSED, UNUSED, UNUSED, UNUSED
+ !
+ ! integer variables:
+ ! NSPTS, NWFID, NXSIZE, NYSIZE, UNUSED
+ ! IINST
+ ! ISTREG IEVREG IEVTYP IQUAL ISYNTH
+ ! IMAGTYP, IMAGSRC, UNUSED, UNUSED, UNUSED
+ !
+ write(IOUT_SAC,520) NZYEAR, NZJDAY, NZHOUR, NZMIN, NZSEC
+ write(IOUT_SAC,520) NZMSEC, NVHDR, NORID, NEVID, NPTS
+ write(IOUT_SAC,520) int(undef),int(undef),int(undef),int(undef),int(undef)
+ write(IOUT_SAC,520) IFTYPE, IDEP, IZTYPE, int(UNUSED), int(undef)
+ write(IOUT_SAC,520) int(undef),int(undef),IEVTYP, int(undef), ISYNTH
+ write(IOUT_SAC,520) IMAGTYP,int(undef),int(undef),int(undef),int(undef)
+ write(IOUT_SAC,520) int(UNUSED), int(UNUSED), int(UNUSED), int(UNUSED), int(UNUSED)
+ write(IOUT_SAC,520) LEVEN, LPSPOL, LOVROK, LCALDA, int(UNUSED)
+ write(IOUT_SAC,530) KSTNM, KEVNM
+ !
+ ! character variables:
+ !
+ ! KHOLE KO KA
+ ! KT0 KT1 KT2
+ ! KT3 KT4 KT5
+ ! KT6 KT7 KT8
+ ! KT9 KF KUSER0
+ ! KUSER1 KUSER2 KCMPNM
+ ! KNETWK KDATRD KINST
+ !
+ write(IOUT_SAC,540) '-12345 ','-12345 ','-12345 '
+ write(IOUT_SAC,540) '-12345 ','-12345 ','-12345 '
+ write(IOUT_SAC,540) '-12345 ','-12345 ','-12345 '
+ write(IOUT_SAC,540) '-12345 ','-12345 ','-12345 '
+ write(IOUT_SAC,540) '-12345 ','-12345 ',KUSER0
+ write(IOUT_SAC,540) KUSER1, KUSER2, KCMPNM
+ write(IOUT_SAC,540) KNETWK,'-12345 ','-12345 '
+ endif
+
+ ! now write data - with five values per row:
+ ! ---------------
+
+ do isample = 1+5,seismo_current+1,5
+
+ value1 = dble(seismogram_tmp(iorientation,isample-5))
+ value2 = dble(seismogram_tmp(iorientation,isample-4))
+ value3 = dble(seismogram_tmp(iorientation,isample-3))
+ value4 = dble(seismogram_tmp(iorientation,isample-2))
+ value5 = dble(seismogram_tmp(iorientation,isample-1))
+
+ write(IOUT_SAC,510) sngl(value1),sngl(value2),sngl(value3),sngl(value4),sngl(value5)
+
+ enddo
+
+ close(IOUT_SAC)
+
+ endif ! OUTPUT_SEISMOS_SAC_ALPHANUM
+
+ ! For explaination on values set, see above (SAC ASCII)
+ if (OUTPUT_SEISMOS_SAC_BINARY) then
+
+ ! add .sac (sac binary) extension to seismogram file name for SAC seismograms
+ write(sisname_2,"('/',a,'.sac')") trim(sisname)
+
+ ! open binary file
+ if (seismo_offset == 0) then
+ call open_file_create(trim(OUTPUT_FILES)//trim(sisname_2)//char(0))
+ else
+ call open_file_append(trim(OUTPUT_FILES)//trim(sisname_2)//char(0))
+ endif
+
+ if (seismo_offset == 0) then
+ ! write header variables
+
+ ! write single precision header variables 1:70
+ call write_real(DELTA) !(1)
+ call write_real(DEPMIN) !(2)
+ call write_real(DEPMAX) !(3)
+ call write_real(SCALE_F) !(4)
+ call write_real(ODELTA) !(5)
+ call write_real(B) !(6)
+ call write_real(E) !(7)
+ call write_real(O) !(8)
+ call write_real(A) !(9)
+ call write_real(INTERNAL) !(10)
+ call write_real(undef) !(11)T0
+ call write_real(undef) !(12)T1
+ call write_real(undef) !(13)T2
+ call write_real(undef) !(14)T3
+ call write_real(undef) !(15)T4
+ call write_real(undef) !(16)T5
+ call write_real(undef) !(17)T6
+ call write_real(undef) !(18)T7
+ call write_real(undef) !(19)T8
+ call write_real(undef) !(20)T9
+ call write_real(undef) !(21)F
+ call write_real(undef) !(22)RESP0
+ call write_real(undef) !(23)RESP1
+ call write_real(undef) !(24)RESP2
+ call write_real(undef) !(25)RESP3
+ call write_real(undef) !(26)RESP4
+ call write_real(undef) !(27)RESP5
+ call write_real(undef) !(28)RESP6
+ call write_real(undef) !(29)RESP7
+ call write_real(undef) !(30)RESP8
+ call write_real(undef) !(31)RESP9
+ call write_real(STLA) !(32)
+ call write_real(STLO) !(33)
+ call write_real(STEL) !(34)
+ call write_real(STDP) !(35)
+ call write_real(EVLA) !(36)
+ call write_real(EVLO) !(37)
+ call write_real(EVEL) !(38)
+ call write_real(EVDP) !(39)
+ call write_real(MAG) !(40)
+ call write_real(USER0) !(41)USER0
+ call write_real(USER1) !(42)USER1
+ call write_real(USER2) !(43)USER2
+ call write_real(undef) !(44)USER3
+ call write_real(undef) !(45)USER4
+ call write_real(undef) !(46)USER5
+ call write_real(undef) !(47)USER6
+ call write_real(undef) !(48)USER7
+ call write_real(undef) !(49)USER8
+ call write_real(undef) !(50)USER9
+ call write_real(DIST) !(51)
+ call write_real(AZ) !(52)
+ call write_real(BAZ) !(53)
+ call write_real(GCARC) !(54)
+ call write_real(INTERNAL) !(55)
+ call write_real(INTERNAL) !(56)
+ call write_real(DEPMEN) !(57)
+ call write_real(CMPAZ) !(58)
+ call write_real(CMPINC) !(59)
+ call write_real(undef) !(60)XMINIMUM
+ call write_real(undef) !(61)XMAXIMUM
+ call write_real(undef) !(62)YMINIMUM
+ call write_real(undef) !(63)YMAXIMUM
+ call write_real(undef) !(64)
+ call write_real(undef) !(65)
+ call write_real(undef) !(66)
+ call write_real(undef) !(67)
+ call write_real(undef) !(68)
+ call write_real(undef) !(69)
+ call write_real(undef) !(70)
+
+ ! write integer header variables 71:105
+ call write_integer(NZYEAR) !(71)
+ call write_integer(NZJDAY) !(72)
+ call write_integer(NZHOUR) !(73)
+ call write_integer(NZMIN) !(74)
+ call write_integer(NZSEC) !(75)
+ call write_integer(NZMSEC) !(76)
+ call write_integer(NVHDR) !(77)
+ call write_integer(NORID) !(78)
+ call write_integer(NEVID) !(79)
+ call write_integer(NPTS) !(80)
+ call write_integer(int(undef)) !(81)UNUSED
+ call write_integer(int(undef)) !(82)NWFID
+ call write_integer(int(undef)) !(83)NXSIZE
+ call write_integer(int(undef)) !(84)NYSIZE
+ call write_integer(int(undef)) !(85)UNUSED
+ call write_integer(IFTYPE) !(86)
+ call write_integer(IDEP) !(87)
+ call write_integer(IZTYPE) !(88)
+ call write_integer(int(undef)) !(89)UNUSED
+ call write_integer(int(undef)) !(90)IINST
+ call write_integer(int(undef)) !(91)ISTREG
+ call write_integer(int(undef)) !(92)IEVREG
+ call write_integer(IEVTYP) !(93)
+ call write_integer(int(undef)) !(94)IQUAL
+ call write_integer(ISYNTH) !(95)
+ call write_integer(IMAGTYP) !(96)
+ call write_integer(int(undef)) !(97)IMAGSRC
+ call write_integer(int(UNUSED)) !(98)
+ call write_integer(int(UNUSED)) !(99)
+ call write_integer(int(UNUSED)) !(100)
+ call write_integer(int(UNUSED)) !(101)
+ call write_integer(int(UNUSED)) !(102)
+ call write_integer(int(UNUSED)) !(103)
+ call write_integer(int(UNUSED)) !(104)
+ call write_integer(int(UNUSED)) !(105)
+
+ ! write logical header variables 106:110
+ call write_integer(LEVEN) !(106)
+ call write_integer(LPSPOL) !(107)
+ call write_integer(LOVROK) !(108)
+ call write_integer(LCALDA) !(109)
+ call write_integer(int(UNUSED)) !(110)
+
+
+ ! write character header variables 111:302
+ call write_character(KSTNM,8) !(111:118)
+ call write_character(KEVNM,16) !(119:134)
+ call write_character(str_undef,8) !(135:142)KHOLE
+ call write_character(str_undef,8) !(143:150)KO
+ call write_character(str_undef,8) !(151:158)KA
+ call write_character(str_undef,8) !(159:166)KT0
+ call write_character(str_undef,8) !(167:174)KT1
+ call write_character(str_undef,8) !(175:182)KT2
+ call write_character(str_undef,8) !(183:190)KT3
+ call write_character(str_undef,8) !(191:198)KT4
+ call write_character(str_undef,8) !(199:206)KT5
+ call write_character(str_undef,8) !(207:214)KT6
+ call write_character(str_undef,8) !(215:222)KT7
+ call write_character(str_undef,8) !(223:230)KT8
+ call write_character(str_undef,8) !(231:238)KT9
+ call write_character(str_undef,8) !(239:246)KF
+ call write_character(KUSER0,8) !(247:254)
+ call write_character(KUSER1,8) !(255:262)
+ call write_character(KUSER2,8) !(263:270)
+ call write_character(KCMPNM,8) !(271:278)
+ call write_character(KNETWK,8) !(279:286)
+ call write_character(str_undef,8) !(287:294)KDATRD
+ call write_character(str_undef,8) !(295:302)KINST
+
+ endif
+
+ ! now write SAC time series to file
+ ! BS BS write whole time series at once (hope to increase I/O performance
+ ! compared to using a loop on it)
+
+ if (CUSTOM_REAL == SIZE_REAL) then
+ call write_n_real(seismogram_tmp(iorientation,1:seismo_current),seismo_current)
+ elseif (CUSTOM_REAL == SIZE_DOUBLE) then
+ call write_n_real(real(seismogram_tmp(iorientation,1:seismo_current)),seismo_current)
+ endif
+
+ call close_file()
+
+ endif ! OUTPUT_SEISMOS_SAC_BINARY
+
+!#################### end SAC Alphanumeric Seismos ############################
+
+ end subroutine write_output_SAC
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_seismograms.f90 (from rev 17976, seismo/3D/SPECFEM3D_GLOBE/trunk/write_seismograms.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_seismograms.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/write_seismograms.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -0,0 +1,594 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! write seismograms to files
+ subroutine write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,tshift_cmt,t_shift, &
+ elat,elon,depth,event_name,cmt_lat,cmt_lon, &
+ cmt_depth,cmt_hdur,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,NEX_XI !,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,ANGULAR_WIDTH_XI_IN_DEGREES
+
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+ double precision tshift_cmt,t_shift,elat,elon,depth
+ double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
+ double precision, dimension(nrec) :: stlat,stlon,stele,stbur
+ integer yr,jda,ho,mi
+ double precision sec
+ !real mb
+! character(len=12) ename
+ character(len=20) event_name
+
+! 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',action='write')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
+ form='unformatted',position='append',action='write')
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted',action='write')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='old',&
+ form='formatted',position='append',action='write')
+ endif
+ endif
+ endif
+
+ total_seismos_local = 0
+
+ ! loop on all the local receivers
+ do irec_local = 1,nrec_local
+
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+ total_seismos_local = total_seismos_local + 1
+
+ one_seismogram = seismograms(:,irec_local,:)
+
+ ! write this seismogram
+ call write_one_seismogram(one_seismogram,irec, &
+ station_name,network_name,stlat,stlon,stele,stbur,nrec, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,tshift_cmt,t_shift, &
+ elat,elon,depth,event_name,cmt_lat, &
+ cmt_lon,cmt_depth,cmt_hdur,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
+
+ ! 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) close(IOUT)
+
+ if(total_seismos_local/= nrec_local) call exit_MPI(myrank,'incorrect total number of receivers saved')
+
+ write_time = MPI_WTIME() - write_time_begin
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Writing the seismograms in parallel took ',write_time,' seconds'
+ write(IMAIN,*)
+ endif
+
+ ! now only the master process does the writing of seismograms and
+ ! collects the data from all other processes
+ else ! WRITE_SEISMOGRAMS_BY_MASTER
+
+ write_time_begin = MPI_WTIME()
+
+ if(myrank == 0) then ! on the master, gather all the seismograms
+
+ ! create one large file instead of one small file per station to avoid file system overload
+ if(OUTPUT_SEISMOS_ASCII_TEXT .and. SAVE_ALL_SEISMOS_IN_ONE_FILE) then
+ write(sisname,'(A)') '/all_seismograms'
+
+ if(USE_BINARY_FOR_LARGE_FILE) then
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='unknown',form='unformatted',action='write')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
+ form='unformatted',position='append',action='write')
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted',action='write')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='old',&
+ form='formatted',position='append',action='write')
+ endif
+ endif
+
+ endif
+
+ total_seismos = 0
+
+ ! loop on all the slices
+ do iproc = 0,NPROCTOT-1
+
+ ! receive except from proc 0, which is me and therefore I already have this value
+ sender = iproc
+ if(iproc /= 0) then
+ call MPI_RECV(nrec_local_received,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ if(nrec_local_received < 0) call exit_MPI(myrank,'error while receiving local number of receivers')
+ else
+ nrec_local_received = nrec_local
+ endif
+ if (nrec_local_received > 0) then
+ do irec_local = 1,nrec_local_received
+ ! receive except from proc 0, which is myself and therefore I already have these values
+ if(iproc == 0) then
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+ one_seismogram(:,:) = seismograms(:,irec_local,:)
+ else
+ call MPI_RECV(irec,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ if(irec < 1 .or. irec > nrec) call exit_MPI(myrank,'error while receiving global receiver number')
+ call MPI_RECV(one_seismogram,NDIM*seismo_current,CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ endif
+
+ total_seismos = total_seismos + 1
+ ! write this seismogram
+ call write_one_seismogram(one_seismogram,irec, &
+ station_name,network_name,stlat,stlon,stele,stbur,nrec, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,tshift_cmt,t_shift, &
+ elat,elon,depth,event_name,cmt_lat, &
+ cmt_lon,cmt_depth,cmt_hdur,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,stbur,nrec, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,tshift_cmt,t_shift,&
+ elat,elon,depth,event_name,cmt_lat,cmt_lon,cmt_depth,cmt_hdur, &
+ 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,NEX_XI
+
+ 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,ANGULAR_WIDTH_XI_IN_DEGREES
+
+ 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
+
+ character(len=4) chn
+ character(len=256) sisname,sisname_big_file
+ character(len=150) OUTPUT_FILES
+
+ ! section added for SAC
+ double precision tshift_cmt,t_shift,elat,elon,depth
+ double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
+
+ double precision, dimension(nrec) :: stlat,stlon,stele,stbur
+
+ ! variables for SAC header fields
+ integer yr,jda,ho,mi
+ double precision sec
+ character(len=20) event_name
+
+ ! 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
+
+! local parameters
+ character(len=2) bic
+ ! 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
+ integer isample
+
+ !----------------------------------------------------------------
+
+ call band_instrument_code(DT,bic)
+ 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'
+ chn = bic(1:2)//'N'
+ else if(iorientation == 2) then
+ !chn = 'LHE'
+ chn = bic(1:2)//'E'
+ else if(iorientation == 3) then
+ !chn = 'LHZ'
+ chn = bic(1:2)//'Z'
+ else if(iorientation == 4) then
+ !chn = 'LHR'
+ chn = bic(1:2)//'R'
+ else if(iorientation == 5) then
+ !chn = 'LHT'
+ chn = bic(1:2)//'T'
+ 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
+ ! call get_backazimuth(elat,elon,stlat(irec),stlon(irec),backaz)
+ call get_backazimuth(cmt_lat,cmt_lon,stlat(irec),stlon(irec),backaz)
+
+ phi = backaz
+ if (phi>180.) then
+ phi = phi-180.
+ elseif (phi<180.) then
+ phi = phi+180.
+ elseif (phi==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,'.sem')") 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,'.sem')") station_name(irec)(1:length_station_name), &
+ network_name(irec)(1:length_network_name),chn
+
+ ! SAC output format
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM .or. OUTPUT_SEISMOS_SAC_BINARY) then
+
+ call write_output_SAC(seismogram_tmp,irec, &
+ station_name,network_name,stlat,stlon,stele,stbur,nrec, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,tshift_cmt,t_shift,&
+ elat,elon,depth,event_name,cmt_lat,cmt_lon,cmt_depth,cmt_hdur, &
+ OUTPUT_FILES, &
+ OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
+ iorientation,phi,chn,sisname)
+
+ endif ! OUTPUT_SEISMOS_SAC_ALPHANUM .or. OUTPUT_SEISMOS_SAC_BINARY
+
+ ! ASCII output format
+ if(OUTPUT_SEISMOS_ASCII_TEXT) then
+
+ call write_output_ASCII(seismogram_tmp, &
+ DT,hdur,OUTPUT_FILES, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank, &
+ iorientation,sisname,sisname_big_file)
+
+ endif ! OUTPUT_SEISMOS_ASCII_TEXT
+
+ enddo ! do iorientation
+
+ end subroutine write_one_seismogram
+
+!=====================================================================
+
+! write adjoint seismograms to text files
+
+ subroutine write_adj_seismograms(seismograms,number_receiver_global, &
+ nrec_local,it,nit_written,DT,NSTEP, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,hdur,LOCAL_PATH)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nrec_local,NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,it,nit_written
+ integer, dimension(nrec_local) :: number_receiver_global
+ real(kind=CUSTOM_REAL), dimension(9,nrec_local,NSTEP) :: seismograms
+ double precision hdur,DT
+ character(len=150) LOCAL_PATH
+
+ integer irec,irec_local
+ integer iorientation,isample
+
+ character(len=4) chn
+ character(len=150) clean_LOCAL_PATH,final_LOCAL_PATH
+ character(len=256) sisname
+ character(len=2) bic
+
+ call band_instrument_code(DT,bic)
+
+ do irec_local = 1,nrec_local
+
+! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+ do iorientation = 1,9
+
+ if(iorientation == 1) then
+ chn = 'SNN'
+ else if(iorientation == 2) then
+ chn = 'SEE'
+ else if(iorientation == 3) then
+ chn = 'SZZ'
+ else if(iorientation == 4) then
+ chn = 'SNE'
+ else if(iorientation == 5) then
+ chn = 'SNZ'
+ else if(iorientation == 6) then
+ chn = 'SEZ'
+ else if(iorientation == 7) then
+ !chn = 'LHN'
+ chn = bic(1:2)//'N'
+ else if(iorientation == 8) then
+ chn = bic(1:2)//'E'
+ else if(iorientation == 9) then
+ chn = bic(1:2)//'Z'
+ endif
+
+
+! create the name of the seismogram file for each slice
+! file name includes the name of the station, the network and the component
+ write(sisname,"(a,i6.6,'.',a,'.',a3,'.sem')") 'S',irec,'NT',chn
+
+! suppress white spaces if any
+ clean_LOCAL_PATH = adjustl(LOCAL_PATH)
+
+! create full final local path
+ final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
+
+! 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
+ if(it <= NTSTEP_BETWEEN_OUTPUT_SEISMOS) then
+ !open new file
+ open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),&
+ status='unknown',action='write')
+ else if(it > NTSTEP_BETWEEN_OUTPUT_SEISMOS) then
+ !append to existing file
+ open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),&
+ status='old',position='append',action='write')
+ endif
+! make sure we never write more than the maximum number of time steps
+! subtract half duration of the source to make sure travel time is correct
+ do isample = nit_written+1,min(it,NSTEP)
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IOUT,*) sngl(dble(isample-1)*DT - hdur),' ',seismograms(iorientation,irec_local,isample-nit_written)
+ else
+ write(IOUT,*) dble(isample-1)*DT - hdur,' ',seismograms(iorientation,irec_local,isample-nit_written)
+ endif
+ enddo
+
+ close(IOUT)
+
+ enddo
+
+ enddo
+
+ end subroutine write_adj_seismograms
+
+!=====================================================================
+
+ subroutine band_instrument_code(DT,bic)
+ ! This subroutine is to choose the appropriate band and instrument codes for channel names of seismograms
+ ! based on the IRIS convention (first two letters of channel codes which were LH(Z/E/N) previously).
+ ! For consistency with observed data, we now use the IRIS convention for band codes (first letter in channel codes)of
+ ! SEM seismograms governed by their sampling rate.
+ ! Instrument code (second letter in channel codes) is fixed to "X" which is assigned by IRIS for synthetic seismograms.
+ ! See the manual for further explanations!
+ ! Ebru, November 2010
+ implicit none
+ double precision DT
+ character(len=2) bic
+
+ if (DT .ge. 1.0d0) bic = 'LX'
+ if (DT .lt. 1.0d0 .and. DT .gt. 0.1d0) bic = 'MX'
+ if (DT .le. 0.1d0 .and. DT .gt. 0.0125d0) bic = 'BX'
+ if (DT .le. 0.0125d0 .and. DT .gt. 0.004d0) bic = 'HX'
+ if (DT .le. 0.004d0 .and. DT .gt. 0.001d0) bic = 'CX'
+ if (DT .le. 0.001d0) bic = 'FX'
+
+ end subroutine band_instrument_code
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/stretching_function.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/stretching_function.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/stretching_function.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,149 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-subroutine 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.
-!
-! stretch_tab array uses indices index_radius & index_layer :
-! stretch_tab( index_radius (1=top,2=bottom) , index_layer (1=first layer, 2=second layer,..) )
-
- 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
-
- ! initializes array
- ! for example: 2 element layers (ner=2) for most probable resolutions (NEX < 1000) in the crust
- ! then stretch_tab(2,1) = 0.5 = stretch_tab(2,2)
- 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
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
-subroutine stretching_function_regional(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.
-!
-! stretch_tab array uses indices index_radius & index_layer :
-! stretch_tab( index_radius (1=top,2=bottom) , index_layer (1=first layer, 2=second layer,..) )
-
- 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
-!
-! ! initializes array
-! ! for example: 2 element layers (ner=2) for most probable resolutions (NEX < 1000) in the crust
-! ! then stretch_tab(2,1) = 0.5 = stretch_tab(2,2)
-! 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
-
- if( ner /= 3 ) stop 'error regional stretching function: ner value'
-
- stretch_tab(1,1) = r_top
- stretch_tab(1,2) = 6356000.d0 ! 15km second layer top
- stretch_tab(1,3) = 6336000.d0 ! 35km third layer top
-
- stretch_tab(2,1) = 6356000.d0 ! bottom first layer
- stretch_tab(2,2) = 6336000.d0 ! bottom second layer
- stretch_tab(2,3) = r_bottom ! bottom third layer
-
-end subroutine stretching_function_regional
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_chunks_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_chunks_data.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_chunks_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,648 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! create AVS or DX 2D data for the faces of the global chunks,
-! to be recombined in postprocessing
- subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
-
- implicit none
-
- include "constants.h"
-
- integer nspec,myrank
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
- logical iboun(6,nspec),ELLIPTICITY,ISOTROPIC_3D_MANTLE
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
- R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to output global points only once
- integer npointot
- logical mask_ibool(npointot)
-
-! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
-
- integer ispec
- integer i,j,k,np
- integer, dimension(8) :: iglobval
- integer npoin,numpoin,nspecface,ispecface
-
- real(kind=CUSTOM_REAL) vmin,vmax
-
- double precision r,rho,vp,vs,Qkappa,Qmu
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
- real(kind=CUSTOM_REAL) dvp,dvs
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
-! processor identification
- character(len=150) prname
-
- integer iregion_code
-
-
-! writing points
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='unknown')
- open(unit=11,file=prname(1:len_trim(prname))//'AVS_DXpointschunks_stability.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- nspecface = 0
-
-! mark global AVS or DX points
- do ispec=1,nspec
-! only if on face
- if(iboun(1,ispec) .or. iboun(2,ispec) .or. &
- iboun(3,ispec) .or. iboun(4,ispec)) then
- iglobval(1)=ibool(1,1,1,ispec)
- iglobval(2)=ibool(NGLLX,1,1,ispec)
- iglobval(3)=ibool(NGLLX,NGLLY,1,ispec)
- iglobval(4)=ibool(1,NGLLY,1,ispec)
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
-! face xi = xi_min
- if(iboun(1,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(1)) = .true.
- mask_ibool(iglobval(4)) = .true.
- mask_ibool(iglobval(8)) = .true.
- mask_ibool(iglobval(5)) = .true.
- endif
-
-! face xi = xi_max
- if(iboun(2,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(2)) = .true.
- mask_ibool(iglobval(3)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(6)) = .true.
- endif
-
-! face eta = eta_min
- if(iboun(3,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(1)) = .true.
- mask_ibool(iglobval(2)) = .true.
- mask_ibool(iglobval(6)) = .true.
- mask_ibool(iglobval(5)) = .true.
- endif
-
-! face eta = eta_max
- if(iboun(4,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(4)) = .true.
- mask_ibool(iglobval(3)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(8)) = .true.
- endif
-
- endif
- enddo
-
-! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
-! number of points in AVS or DX file
- write(10,*) npoin
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! output global AVS or DX points
- numpoin = 0
- do ispec=1,nspec
-! only if on face
- if(iboun(1,ispec) .or. iboun(2,ispec) .or. &
- iboun(3,ispec) .or. iboun(4,ispec)) then
- iglobval(1)=ibool(1,1,1,ispec)
- iglobval(2)=ibool(NGLLX,1,1,ispec)
- iglobval(3)=ibool(NGLLX,NGLLY,1,ispec)
- iglobval(4)=ibool(1,NGLLY,1,ispec)
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
-! face xi = xi_min
- if(iboun(1,ispec)) then
-
- if(.not. mask_ibool(iglobval(1))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(1)) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
- sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
- vmax = sqrt((kappavstore(1,1,1,ispec)+4.*muvstore(1,1,1,ispec)/3.)/rhostore(1,1,1,ispec))
- vmin = sqrt(muvstore(1,1,1,ispec)/rhostore(1,1,1,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,1,1,ispec)**2 + ystore(1,1,1,ispec)**2 + zstore(1,1,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(4))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(4)) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
- sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
- vmax = sqrt((kappavstore(1,NGLLY,1,ispec)+4.*muvstore(1,NGLLY,1,ispec)/3.)/rhostore(1,NGLLY,1,ispec))
- vmin = sqrt(muvstore(1,NGLLY,1,ispec)/rhostore(1,NGLLY,1,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,NGLLY,1,ispec)**2 + ystore(1,NGLLY,1,ispec)**2 + zstore(1,NGLLY,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(8))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(8)) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
- vmax = sqrt((kappavstore(1,NGLLY,NGLLZ,ispec)+4.*muvstore(1,NGLLY,NGLLZ,ispec)/3.)/rhostore(1,NGLLY,NGLLZ,ispec))
- vmin = sqrt(muvstore(1,NGLLY,NGLLZ,ispec)/rhostore(1,NGLLY,NGLLZ,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,NGLLY,NGLLZ,ispec)**2 + ystore(1,NGLLY,NGLLZ,ispec)**2 + zstore(1,NGLLY,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(5))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(5)) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
- sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
- vmax = sqrt((kappavstore(1,1,NGLLZ,ispec)+4.*muvstore(1,1,NGLLZ,ispec)/3.)/rhostore(1,1,NGLLZ,ispec))
- vmin = sqrt(muvstore(1,1,NGLLZ,ispec)/rhostore(1,1,NGLLZ,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,1,NGLLZ,ispec)**2 + ystore(1,1,NGLLZ,ispec)**2 + zstore(1,1,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- mask_ibool(iglobval(1)) = .true.
- mask_ibool(iglobval(4)) = .true.
- mask_ibool(iglobval(8)) = .true.
- mask_ibool(iglobval(5)) = .true.
- endif
-
-! face xi = xi_max
- if(iboun(2,ispec)) then
-
- if(.not. mask_ibool(iglobval(2))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(2)) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
- sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
- vmax = sqrt((kappavstore(NGLLX,1,1,ispec)+4.*muvstore(NGLLX,1,1,ispec)/3.)/rhostore(NGLLX,1,1,ispec))
- vmin = sqrt(muvstore(NGLLX,1,1,ispec)/rhostore(NGLLX,1,1,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,1,1,ispec)**2 + ystore(NGLLX,1,1,ispec)**2 + zstore(NGLLX,1,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(3))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(3)) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
- sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
- vmax = sqrt((kappavstore(NGLLX,NGLLY,1,ispec)+4.*muvstore(NGLLX,NGLLY,1,ispec)/3.)/rhostore(NGLLX,NGLLY,1,ispec))
- vmin = sqrt(muvstore(NGLLX,NGLLY,1,ispec)/rhostore(NGLLX,NGLLY,1,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,NGLLY,1,ispec)**2 + ystore(NGLLX,NGLLY,1,ispec)**2 + zstore(NGLLX,NGLLY,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(7))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(7)) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
- vmax = sqrt((kappavstore(NGLLX,NGLLY,NGLLZ,ispec)+4.*muvstore(NGLLX,NGLLY,NGLLZ,ispec)/3.)/rhostore(NGLLX,NGLLY,NGLLZ,ispec))
- vmin = sqrt(muvstore(NGLLX,NGLLY,NGLLZ,ispec)/rhostore(NGLLX,NGLLY,NGLLZ,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,NGLLY,NGLLZ,ispec)**2 + ystore(NGLLX,NGLLY,NGLLZ,ispec)**2 + zstore(NGLLX,NGLLY,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(6))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(6)) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
- vmax = sqrt((kappavstore(NGLLX,1,NGLLZ,ispec)+4.*muvstore(NGLLX,1,NGLLZ,ispec)/3.)/rhostore(NGLLX,1,NGLLZ,ispec))
- vmin = sqrt(muvstore(NGLLX,1,NGLLZ,ispec)/rhostore(NGLLX,1,NGLLZ,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,1,NGLLZ,ispec)**2 + ystore(NGLLX,1,NGLLZ,ispec)**2 + zstore(NGLLX,1,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- mask_ibool(iglobval(2)) = .true.
- mask_ibool(iglobval(3)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(6)) = .true.
- endif
-
-! face eta = eta_min
- if(iboun(3,ispec)) then
-
- if(.not. mask_ibool(iglobval(1))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(1)) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
- sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
- vmax = sqrt((kappavstore(1,1,1,ispec)+4.*muvstore(1,1,1,ispec)/3.)/rhostore(1,1,1,ispec))
- vmin = sqrt(muvstore(1,1,1,ispec)/rhostore(1,1,1,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,1,1,ispec)**2 + ystore(1,1,1,ispec)**2 + zstore(1,1,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(2))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(2)) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
- sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
- vmax = sqrt((kappavstore(NGLLX,1,1,ispec)+4.*muvstore(NGLLX,1,1,ispec)/3.)/rhostore(NGLLX,1,1,ispec))
- vmin = sqrt(muvstore(NGLLX,1,1,ispec)/rhostore(NGLLX,1,1,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,1,1,ispec)**2 + ystore(NGLLX,1,1,ispec)**2 + zstore(NGLLX,1,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(6))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(6)) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
- vmax = sqrt((kappavstore(NGLLX,1,NGLLZ,ispec)+4.*muvstore(NGLLX,1,NGLLZ,ispec)/3.)/rhostore(NGLLX,1,NGLLZ,ispec))
- vmin = sqrt(muvstore(NGLLX,1,NGLLZ,ispec)/rhostore(NGLLX,1,NGLLZ,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,1,NGLLZ,ispec)**2 + ystore(NGLLX,1,NGLLZ,ispec)**2 + zstore(NGLLX,1,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(5))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(5)) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
- sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
- vmax = sqrt((kappavstore(1,1,NGLLZ,ispec)+4.*muvstore(1,1,NGLLZ,ispec)/3.)/rhostore(1,1,NGLLZ,ispec))
- vmin = sqrt(muvstore(1,1,NGLLZ,ispec)/rhostore(1,1,NGLLZ,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,1,NGLLZ,ispec)**2 + ystore(1,1,NGLLZ,ispec)**2 + zstore(1,1,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- mask_ibool(iglobval(1)) = .true.
- mask_ibool(iglobval(2)) = .true.
- mask_ibool(iglobval(6)) = .true.
- mask_ibool(iglobval(5)) = .true.
- endif
-
-! face eta = eta_max
- if(iboun(4,ispec)) then
-
- if(.not. mask_ibool(iglobval(4))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(4)) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
- sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
- vmax = sqrt((kappavstore(1,NGLLY,1,ispec)+4.*muvstore(1,NGLLY,1,ispec)/3.)/rhostore(1,NGLLY,1,ispec))
- vmin = sqrt(muvstore(1,NGLLY,1,ispec)/rhostore(1,NGLLY,1,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,NGLLY,1,ispec)**2 + ystore(1,NGLLY,1,ispec)**2 + zstore(1,NGLLY,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(3))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(3)) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
- sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
- vmax = sqrt((kappavstore(NGLLX,NGLLY,1,ispec)+4.*muvstore(NGLLX,NGLLY,1,ispec)/3.)/rhostore(NGLLX,NGLLY,1,ispec))
- vmin = sqrt(muvstore(NGLLX,NGLLY,1,ispec)/rhostore(NGLLX,NGLLY,1,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,NGLLY,1,ispec)**2 + ystore(NGLLX,NGLLY,1,ispec)**2 + zstore(NGLLX,NGLLY,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(7))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(7)) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
- vmax = sqrt((kappavstore(NGLLX,NGLLY,NGLLZ,ispec)+4.*muvstore(NGLLX,NGLLY,NGLLZ,ispec)/3.)/rhostore(NGLLX,NGLLY,NGLLZ,ispec))
- vmin = sqrt(muvstore(NGLLX,NGLLY,NGLLZ,ispec)/rhostore(NGLLX,NGLLY,NGLLZ,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,NGLLY,NGLLZ,ispec)**2 + ystore(NGLLX,NGLLY,NGLLZ,ispec)**2 + zstore(NGLLX,NGLLY,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- if(.not. mask_ibool(iglobval(8))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(8)) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
- vmax = sqrt((kappavstore(1,NGLLY,NGLLZ,ispec)+4.*muvstore(1,NGLLY,NGLLZ,ispec)/3.)/rhostore(1,NGLLY,NGLLZ,ispec))
- vmin = sqrt(muvstore(1,NGLLY,NGLLZ,ispec)/rhostore(1,NGLLY,NGLLZ,ispec))
-! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,NGLLY,NGLLZ,ispec)**2 + ystore(1,NGLLY,NGLLZ,ispec)**2 + zstore(1,NGLLY,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- write(11,*) numpoin,vmin,vmax
- endif
-
- mask_ibool(iglobval(4)) = .true.
- mask_ibool(iglobval(3)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(8)) = .true.
- endif
-
- endif
- enddo
-
-! check that number of global points output is okay
- if(numpoin /= npoin) &
- call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
-
- close(10)
- close(11)
-
-! output global AVS or DX elements
-
-! writing elements
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementschunks.txt',status='unknown')
- if(ISOTROPIC_3D_MANTLE) &
- open(unit=11,file=prname(1:len_trim(prname))//'AVS_DXelementschunks_dvp_dvs.txt',status='unknown')
-
-! number of elements in AVS or DX file
- write(10,*) nspecface
-
- ispecface = 0
- do ispec=1,nspec
-! only if on face
- if(iboun(1,ispec) .or. iboun(2,ispec) .or. &
- iboun(3,ispec) .or. iboun(4,ispec)) then
- iglobval(1)=ibool(1,1,1,ispec)
- iglobval(2)=ibool(NGLLX,1,1,ispec)
- iglobval(3)=ibool(NGLLX,NGLLY,1,ispec)
- iglobval(4)=ibool(1,NGLLY,1,ispec)
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
-! include lateral variations if needed
-
- if(ISOTROPIC_3D_MANTLE) then
-! pick a point within the element and get its radius
- r=dsqrt(xstore(2,2,2,ispec)**2+ystore(2,2,2,ispec)**2+zstore(2,2,2,ispec)**2)
-
- if(r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then
-! average over the element
- dvp = 0.0
- dvs = 0.0
- np =0
- do k=2,NGLLZ-1
- do j=2,NGLLY-1
- do i=2,NGLLX-1
- np=np+1
- x=xstore(i,j,k,ispec)
- y=ystore(i,j,k,ispec)
- z=zstore(i,j,k,ispec)
- r=dsqrt(x*x+y*y+z*z)
- ! take out ellipticity
- if(ELLIPTICITY) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi_dummy)
- cost=dcos(theta)
- p20=0.5d0*(3.0d0*cost*cost-1.0d0)
- call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
- factor=ONE-(TWO/3.0d0)*ell*p20
- r=r/factor
- endif
-
-
- ! gets reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
- call meshfem3D_models_get1D_val(myrank,iregion_code,idoubling(ispec), &
- r,rho,vpv,vph,vsv,vsh,eta_aniso, &
- Qkappa,Qmu,RICB,RCMB, &
- RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
- RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- ! calculates isotropic values
- vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
- + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
- vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
- + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
-
- if( abs(rhostore(i,j,k,ispec))< 1.e-20 ) then
- print*,' attention: rhostore close to zero',rhostore(i,j,k,ispec),r,i,j,k,ispec
- dvp = 0.0
- dvs = 0.0
- else if( abs(sngl(vp))< 1.e-20 ) then
- print*,' attention: vp close to zero',sngl(vp),r,i,j,k,ispec
- dvp = 0.0
- else if( abs(sngl(vs))< 1.e-20 ) then
- print*,' attention: vs close to zero',sngl(vs),r,i,j,k,ispec
- dvs = 0.0
- else
- dvp = dvp + (sqrt((kappavstore(i,j,k,ispec)+4.*muvstore(i,j,k,ispec)/3.)/rhostore(i,j,k,ispec)) - sngl(vp))/sngl(vp)
- dvs = dvs + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) - sngl(vs))/sngl(vs)
- endif
-
- enddo
- enddo
- enddo
- dvp = dvp / np
- dvs = dvs / np
- else
- dvp = 0.0
- dvs = 0.0
- endif
- endif
-
-! face xi = xi_min
- if(iboun(1,ispec)) then
- ispecface = ispecface + 1
- write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(1)), &
- num_ibool_AVS_DX(iglobval(4)),num_ibool_AVS_DX(iglobval(8)), &
- num_ibool_AVS_DX(iglobval(5))
- if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
- endif
-
-! face xi = xi_max
- if(iboun(2,ispec)) then
- ispecface = ispecface + 1
- write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(2)), &
- num_ibool_AVS_DX(iglobval(3)),num_ibool_AVS_DX(iglobval(7)), &
- num_ibool_AVS_DX(iglobval(6))
- if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
- endif
-
-! face eta = eta_min
- if(iboun(3,ispec)) then
- ispecface = ispecface + 1
- write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(1)), &
- num_ibool_AVS_DX(iglobval(2)),num_ibool_AVS_DX(iglobval(6)), &
- num_ibool_AVS_DX(iglobval(5))
- if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
- endif
-
-! face eta = eta_max
- if(iboun(4,ispec)) then
- ispecface = ispecface + 1
- write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(4)), &
- num_ibool_AVS_DX(iglobval(3)),num_ibool_AVS_DX(iglobval(7)), &
- num_ibool_AVS_DX(iglobval(8))
- if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
- endif
-
- endif
- enddo
-
-! check that number of surface elements output is okay
- if(ispecface /= nspecface) &
- call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation')
-
- close(10)
- if(ISOTROPIC_3D_MANTLE) close(11)
-
- end subroutine write_AVS_DX_global_chunks_data
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_data.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,370 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! create AVS or DX 3D data for the slice, to be recombined in postprocessing
- subroutine write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling, &
- xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,npointot)
-
- implicit none
-
- include "constants.h"
-
- integer nspec,myrank
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to output global points only once
- integer npointot
- logical mask_ibool(npointot)
-
-! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
-
- integer ispec
- integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
- integer npoin,numpoin
-
-! processor identification
- character(len=150) prname
-
-! writing points
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpoints.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! mark global AVS or DX points
- do ispec=1,nspec
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob5) = .true.
- mask_ibool(iglob6) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob8) = .true.
- enddo
-
-! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
-! number of points in AVS or DX file
- write(10,*) npoin
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! output global AVS or DX points
- numpoin = 0
- do ispec=1,nspec
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
- if(.not. mask_ibool(iglob1)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob1) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
- sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob2)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob2) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
- sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob3)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob3) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
- sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob4)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob4) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
- sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob5)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob5) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
- sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob6)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob6) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob7)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob7) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob8)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob8) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
- endif
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob5) = .true.
- mask_ibool(iglob6) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob8) = .true.
- enddo
-
-! check that number of global points output is okay
- if(numpoin /= npoin) &
- call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
-
- close(10)
-
-! writing elements
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelements.txt',status='unknown')
-
-! number of elements in AVS or DX file
- write(10,*) nspec
-
-! output global AVS or DX elements
- do ispec=1,nspec
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
- write(10,*) ispec,idoubling(ispec),num_ibool_AVS_DX(iglob1), &
- num_ibool_AVS_DX(iglob2),num_ibool_AVS_DX(iglob3), &
- num_ibool_AVS_DX(iglob4),num_ibool_AVS_DX(iglob5), &
- num_ibool_AVS_DX(iglob6),num_ibool_AVS_DX(iglob7), &
- num_ibool_AVS_DX(iglob8)
- enddo
-
- close(10)
-
- end subroutine write_AVS_DX_global_data
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-!> Hejun
-! write material information for gll points
- subroutine write_AVS_DX_global_data_gll(prname,nspec, &
- xstore,ystore,zstore,rhostore,kappavstore,muvstore,Qmustore,&
- ATTENUATION)
-
- implicit none
-
- include "constants.h"
-
- integer nspec
- character(len=150) prname
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision:: Qmustore(NGLLX,NGLLY,NGLLZ,nspec)
-
- logical :: ATTENUATION
-
- ! local parameters
- double precision,dimension(8):: vp,vs,rho,Qmu
- double precision:: vp_average,vs_average,rho_average,Qmu_average
-
- integer flag(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer ispec,i,j,k
- integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
- integer numpoin,nelem
-
-
-! writing points
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpoints_gll.txt',status='unknown')
-
-! number of points in AVS or DX file
- write(10,*) nspec*NGLLX*NGLLY*NGLLZ
-
-
-! output global AVS or DX points
- numpoin = 0
- do ispec=1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- numpoin = numpoin + 1
- write(10,*) numpoin,sngl(xstore(i,j,k,ispec)),&
- sngl(ystore(i,j,k,ispec)),sngl(zstore(i,j,k,ispec))
- flag(i,j,k,ispec) = numpoin
- end do
- end do
- end do
- enddo
-
- close(10)
-
-! writing elements
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelements_gll.txt',status='unknown')
-
-
-! number of elements in AVS or DX file
- write(10,*) nspec*(NGLLX-1)*(NGLLY-1)*(NGLLZ-1)
-
- nelem = 0
-! output global AVS or DX elements
- do ispec=1,nspec
- do k = 1,NGLLZ-1
- do j = 1,NGLLY-1
- do i = 1,NGLLX-1
- nelem = nelem + 1
- iglob1=flag(i,j,k,ispec)
- iglob2=flag(i+1,j,k,ispec)
- iglob3=flag(i+1,j+1,k,ispec)
- iglob4=flag(i,j+1,k,ispec)
- iglob5=flag(i,j,k+1,ispec)
- iglob6=flag(i+1,j,k+1,ispec)
- iglob7=flag(i+1,j+1,k+1,ispec)
- iglob8=flag(i,j+1,k+1,ispec)
-
- write(10,*) nelem,iglob1, &
- iglob2,iglob3,iglob4,&
- iglob5,iglob6,iglob7,iglob8
- end do
- end do
- end do
- enddo
-
- close(10)
-
-! writing elements properity
- open(unit=1001,file=prname(1:len_trim(prname))//'AVS_DXmaterials_gll.txt',status='unknown')
-
-! number of elements in AVS or DX file
- write(1001,*) nspec*(NGLLX-1)*(NGLLY-1)*(NGLLZ-1)
-
- nelem = 0
-! output global AVS or DX elements
- do ispec=1,nspec
- do k = 1,NGLLZ-1
- do j = 1,NGLLY-1
- do i = 1,NGLLX-1
- nelem = nelem + 1
- rho(1)=dble(rhostore(i,j,k,ispec))
- vs(1)=dble(sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)))
- vp(1)=dble(sqrt(kappavstore(i,j,k,ispec)/rhostore(i,j,k,ispec)+4.d0*vs(1)*vs(1)/3.d0))
-
- rho(2)=dble(rhostore(i+1,j,k,ispec))
- vs(2)=dble(sqrt(muvstore(i+1,j,k,ispec)/rhostore(i+1,j,k,ispec)))
- vp(2)=dble(sqrt(kappavstore(i+1,j,k,ispec)/rhostore(i+1,j,k,ispec)+4.d0*vs(2)*vs(2)/3.d0))
-
- rho(3)=dble(rhostore(i+1,j+1,k,ispec))
- vs(3)=dble(sqrt(muvstore(i+1,j+1,k,ispec)/rhostore(i+1,j+1,k,ispec)))
- vp(3)=dble(sqrt(kappavstore(i+1,j+1,k,ispec)/rhostore(i+1,j+1,k,ispec)+4.d0*vs(3)*vs(3)/3.d0))
-
- rho(4)=dble(rhostore(i,j+1,k,ispec))
- vs(4)=dble(sqrt(muvstore(i,j+1,k,ispec)/rhostore(i,j+1,k,ispec)))
- vp(4)=dble(sqrt(kappavstore(i,j+1,k,ispec)/rhostore(i,j+1,k,ispec)+4.d0*vs(4)*vs(4)/3.d0))
-
- rho(5)=dble(rhostore(i,j,k+1,ispec))
- vs(5)=dble(sqrt(muvstore(i,j,k+1,ispec)/rhostore(i,j,k+1,ispec)))
- vp(5)=dble(sqrt(kappavstore(i,j,k+1,ispec)/rhostore(i,j,k+1,ispec)+4.d0*vs(5)*vs(5)/3.d0))
-
- rho(6)=dble(rhostore(i+1,j,k+1,ispec))
- vs(6)=dble(sqrt(muvstore(i+1,j,k+1,ispec)/rhostore(i+1,j,k+1,ispec)))
- vp(6)=dble(sqrt(kappavstore(i+1,j,k+1,ispec)/rhostore(i+1,j,k+1,ispec)+4.d0*vs(6)*vs(6)/3.d0))
-
- rho(7)=dble(rhostore(i+1,j+1,k+1,ispec))
- vs(7)=dble(sqrt(muvstore(i+1,j+1,k+1,ispec)/rhostore(i+1,j+1,k+1,ispec)))
- vp(7)=dble(sqrt(kappavstore(i+1,j+1,k+1,ispec)/rhostore(i+1,j+1,k+1,ispec)+4.d0*vs(7)*vs(7)/3.d0))
-
- rho(8)=dble(rhostore(i,j+1,k+1,ispec))
- vs(8)=dble(sqrt(muvstore(i,j+1,k+1,ispec)/rhostore(i,j+1,k+1,ispec)))
- vp(8)=dble(sqrt(kappavstore(i,j+1,k+1,ispec)/rhostore(i,j+1,k+1,ispec)+4.d0*vs(8)*vs(8)/3.d0))
-
- if (ATTENUATION) then
- Qmu(1)=dble(Qmustore(i,j,k,ispec))
- Qmu(2)=dble(Qmustore(i+1,j,k,ispec))
- Qmu(3)=dble(Qmustore(i+1,j+1,k,ispec))
- Qmu(4)=dble(Qmustore(i,j+1,k,ispec))
- Qmu(5)=dble(Qmustore(i,j,k+1,ispec))
- Qmu(6)=dble(Qmustore(i+1,j,k+1,ispec))
- Qmu(7)=dble(Qmustore(i+1,j+1,k+1,ispec))
- Qmu(8)=dble(Qmustore(i,j+1,k+1,ispec))
- Qmu_average=Qmu(1)
- end if
- !rho_average=sum(rho(1:4))/4.d0
- !vp_average=sum(vp(1:4))/4.d0
- !vs_average=sum(vs(1:4))/4.d0
- rho_average=rho(1)
- vp_average=vp(1)
- vs_average=vs(1)
-
- if (ATTENUATION) then
- write(1001,*) nelem,rho_average,vp_average,vs_average,Qmu_average
- else
- write(1001,*) nelem,rho_average,vp_average,vs_average
- end if
-
- end do
- end do
- end do
- enddo
-
- close(1001)
-
- end subroutine write_AVS_DX_global_data_gll
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_faces_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_faces_data.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_faces_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,451 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! create AVS or DX 2D data for the faces of the slice,
-! to be recombined in postprocessing
-
- subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
-
- implicit none
-
- include "constants.h"
-
- integer nspec,myrank
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
- logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
-
- logical iMPIcut_xi(2,nspec)
- logical iMPIcut_eta(2,nspec)
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
- R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to output global points only once
- integer npointot
- logical mask_ibool(npointot)
-
-! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
-
- integer ispec
- integer i,j,k,np
- integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
- integer npoin,numpoin,nspecface,ispecface
-
- double precision r,rho,vp,vs,Qkappa,Qmu
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
- real(kind=CUSTOM_REAL) dvp,dvs
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
-! processor identification
- character(len=150) prname
-
- integer iregion_code
-
-! writing points
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- nspecface = 0
-
-! mark global AVS or DX points
- do ispec=1,nspec
-! only if on face
- if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
- iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
-
-! face xi = xi_min
- if(iMPIcut_xi(1,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob8) = .true.
- mask_ibool(iglob5) = .true.
- endif
-
-! face xi = xi_max
- if(iMPIcut_xi(2,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob6) = .true.
- endif
-
-! face eta = eta_min
- if(iMPIcut_eta(1,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob6) = .true.
- mask_ibool(iglob5) = .true.
- endif
-
-! face eta = eta_max
- if(iMPIcut_eta(2,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob8) = .true.
- endif
-
- endif
- enddo
-
-! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
-! number of points in AVS or DX file
- write(10,*) npoin
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! output global AVS or DX points
- numpoin = 0
- do ispec=1,nspec
-! only if on face
- if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
- iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
-
-! face xi = xi_min
- if(iMPIcut_xi(1,ispec)) then
- if(.not. mask_ibool(iglob1)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob1) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
- sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob4)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob4) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
- sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob8)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob8) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob5)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob5) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
- sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
- endif
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob8) = .true.
- mask_ibool(iglob5) = .true.
- endif
-
-! face xi = xi_max
- if(iMPIcut_xi(2,ispec)) then
- if(.not. mask_ibool(iglob2)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob2) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
- sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob3)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob3) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
- sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob7)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob7) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob6)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob6) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
- endif
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob6) = .true.
- endif
-
-! face eta = eta_min
- if(iMPIcut_eta(1,ispec)) then
- if(.not. mask_ibool(iglob1)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob1) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
- sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob2)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob2) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
- sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob6)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob6) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob5)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob5) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
- sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
- endif
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob6) = .true.
- mask_ibool(iglob5) = .true.
- endif
-
-! face eta = eta_max
- if(iMPIcut_eta(2,ispec)) then
- if(.not. mask_ibool(iglob4)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob4) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
- sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob3)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob3) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
- sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob7)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob7) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob8)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob8) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
- endif
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob8) = .true.
- endif
-
- endif
- enddo
-
-! check that number of global points output is okay
- if(numpoin /= npoin) &
- call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
-
- close(10)
-
-! output global AVS or DX elements
-
-! writing elements
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='unknown')
- if(ISOTROPIC_3D_MANTLE) &
- open(unit=11,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces_dvp_dvs.txt',status='unknown')
-
-! number of elements in AVS or DX file
- write(10,*) nspecface
-
- ispecface = 0
- do ispec=1,nspec
-! only if on face
- if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
- iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
-
-! include lateral variations if needed
-
- if(ISOTROPIC_3D_MANTLE) then
- ! pick a point within the element and get its radius
- r=dsqrt(xstore(2,2,2,ispec)**2+ystore(2,2,2,ispec)**2+zstore(2,2,2,ispec)**2)
-
- if(r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then
- ! average over the element
- dvp = 0.0
- dvs = 0.0
- np =0
- do k=2,NGLLZ-1
- do j=2,NGLLY-1
- do i=2,NGLLX-1
- np=np+1
- x=xstore(i,j,k,ispec)
- y=ystore(i,j,k,ispec)
- z=zstore(i,j,k,ispec)
- r=dsqrt(x*x+y*y+z*z)
- ! take out ellipticity
- if(ELLIPTICITY) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi_dummy)
- cost=dcos(theta)
- p20=0.5d0*(3.0d0*cost*cost-1.0d0)
- call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
- factor=ONE-(TWO/3.0d0)*ell*p20
- r=r/factor
- endif
-
-
- ! gets reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
- call meshfem3D_models_get1D_val(myrank,iregion_code,idoubling(ispec), &
- r,rho,vpv,vph,vsv,vsh,eta_aniso, &
- Qkappa,Qmu,RICB,RCMB, &
- RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
- RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- ! calculates isotropic values
- vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
- + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
- vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
- + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
-
- if( abs(rhostore(i,j,k,ispec))< 1.e-20 ) then
- print*,' attention: rhostore close to zero',rhostore(i,j,k,ispec),r,i,j,k,ispec
- dvp = 0.0
- dvs = 0.0
- else if( abs(sngl(vp))< 1.e-20 ) then
- print*,' attention: vp close to zero',sngl(vp),r,i,j,k,ispec
- dvp = 0.0
- else if( abs(sngl(vs))< 1.e-20 ) then
- print*,' attention: vs close to zero',sngl(vs),r,i,j,k,ispec
- dvs = 0.0
- else
- dvp = dvp + (sqrt((kappavstore(i,j,k,ispec)+4.*muvstore(i,j,k,ispec)/3.)/rhostore(i,j,k,ispec)) - sngl(vp))/sngl(vp)
- dvs = dvs + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) - sngl(vs))/sngl(vs)
- endif
-
- enddo
- enddo
- enddo
- dvp = dvp / np
- dvs = dvs / np
- else
- dvp = 0.0
- dvs = 0.0
- endif
- endif
-
-! face xi = xi_min
- if(iMPIcut_xi(1,ispec)) then
- ispecface = ispecface + 1
- write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob1), &
- num_ibool_AVS_DX(iglob4),num_ibool_AVS_DX(iglob8), &
- num_ibool_AVS_DX(iglob5)
- if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
- endif
-
-! face xi = xi_max
- if(iMPIcut_xi(2,ispec)) then
- ispecface = ispecface + 1
- write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob2), &
- num_ibool_AVS_DX(iglob3),num_ibool_AVS_DX(iglob7), &
- num_ibool_AVS_DX(iglob6)
- if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
- endif
-
-! face eta = eta_min
- if(iMPIcut_eta(1,ispec)) then
- ispecface = ispecface + 1
- write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob1), &
- num_ibool_AVS_DX(iglob2),num_ibool_AVS_DX(iglob6), &
- num_ibool_AVS_DX(iglob5)
- if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
- endif
-
-! face eta = eta_max
- if(iMPIcut_eta(2,ispec)) then
- ispecface = ispecface + 1
- write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob4), &
- num_ibool_AVS_DX(iglob3),num_ibool_AVS_DX(iglob7), &
- num_ibool_AVS_DX(iglob8)
- if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
- endif
-
- endif
- enddo
-
-! check that number of surface elements output is okay
- if(ispecface /= nspecface) &
- call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation')
-
- close(10)
- if(ISOTROPIC_3D_MANTLE) close(11)
-
- end subroutine write_AVS_DX_global_faces_data
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_surface_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_surface_data.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_surface_data.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,287 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! create AVS or DX 2D data for the surface of the model
-! to be recombined in postprocessing
- subroutine write_AVS_DX_surface_data(myrank,prname,nspec,iboun, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,npointot,&
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
-
- implicit none
-
- include "constants.h"
-
- integer nspec,myrank
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
- logical iboun(6,nspec)
- logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
- R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- double precision r,rho,vp,vs,Qkappa,Qmu
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
- real(kind=CUSTOM_REAL) dvp,dvs
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to output global points only once
- integer npointot
- logical mask_ibool(npointot)
-
-! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
-
- integer ispec
- integer i,j,k,np
- integer, dimension(8) :: iglobval
- integer npoin,numpoin,nspecface,ispecface
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
-! processor identification
- character(len=150) prname
-
- integer iregion_code
-
-! writing points
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='unknown')
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- nspecface = 0
-
-! mark global AVS or DX points
- do ispec=1,nspec
-! only if at the surface (top plane)
- if(iboun(6,ispec)) then
-
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
-! element is at the surface
- nspecface = nspecface + 1
- mask_ibool(iglobval(5)) = .true.
- mask_ibool(iglobval(6)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(8)) = .true.
-
- endif
- enddo
-
-! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
-! number of points in AVS or DX file
- write(10,*) npoin
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! output global AVS or DX points
- numpoin = 0
- do ispec=1,nspec
-! only if at the surface
- if(iboun(6,ispec)) then
-
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
-! top face
- if(iboun(6,ispec)) then
-
- if(.not. mask_ibool(iglobval(5))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(5)) = numpoin
- write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
- sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
- endif
-
- if(.not. mask_ibool(iglobval(6))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(6)) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
- endif
-
- if(.not. mask_ibool(iglobval(7))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(7)) = numpoin
- write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
- endif
-
- if(.not. mask_ibool(iglobval(8))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(8)) = numpoin
- write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
- sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
- endif
-
- mask_ibool(iglobval(5)) = .true.
- mask_ibool(iglobval(6)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(8)) = .true.
-
- endif
-
- endif
- enddo
-
-! check that number of global points output is okay
- if(numpoin /= npoin) &
- call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
-
- close(10)
-
-! output global AVS or DX elements
-
-! writing elements
- open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='unknown')
- if(ISOTROPIC_3D_MANTLE) &
- open(unit=11,file=prname(1:len_trim(prname))//'AVS_DXelementssurface_dvp_dvs.txt',status='unknown')
-
-! number of elements in AVS or DX file
- write(10,*) nspecface
-
- ispecface = 0
- do ispec=1,nspec
-! only if at the surface
- if(iboun(6,ispec)) then
-
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
- if(ISOTROPIC_3D_MANTLE) then
- ! pick a point within the element and get its radius
- r=dsqrt(xstore(2,2,2,ispec)**2+ystore(2,2,2,ispec)**2+zstore(2,2,2,ispec)**2)
-
- if(r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then
- ! average over the element
- dvp = 0.0
- dvs = 0.0
- np =0
- do k=2,NGLLZ-1
- do j=2,NGLLY-1
- do i=2,NGLLX-1
- np=np+1
- x=xstore(i,j,k,ispec)
- y=ystore(i,j,k,ispec)
- z=zstore(i,j,k,ispec)
- r=dsqrt(x*x+y*y+z*z)
- ! take out ellipticity
- if(ELLIPTICITY) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi_dummy)
- cost=dcos(theta)
- p20=0.5d0*(3.0d0*cost*cost-1.0d0)
- call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
- factor=ONE-(TWO/3.0d0)*ell*p20
- r=r/factor
- endif
-
-
- ! gets reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
- call meshfem3D_models_get1D_val(myrank,iregion_code,idoubling(ispec), &
- r,rho,vpv,vph,vsv,vsh,eta_aniso, &
- Qkappa,Qmu,RICB,RCMB, &
- RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
- RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- ! calculates isotropic values
- vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
- + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
- vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
- + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
-
- if( abs(rhostore(i,j,k,ispec))< 1.e-20 ) then
- print*,' attention: rhostore close to zero',rhostore(i,j,k,ispec),r,i,j,k,ispec
- dvp = 0.0
- dvs = 0.0
- else if( abs(sngl(vp))< 1.e-20 ) then
- print*,' attention: vp close to zero',sngl(vp),r,i,j,k,ispec
- dvp = 0.0
- else if( abs(sngl(vs))< 1.e-20 ) then
- print*,' attention: vs close to zero',sngl(vs),r,i,j,k,ispec
- dvs = 0.0
- else
- dvp = dvp + (sqrt((kappavstore(i,j,k,ispec)+4.*muvstore(i,j,k,ispec)/3.) &
- /rhostore(i,j,k,ispec)) - sngl(vp))/sngl(vp)
- dvs = dvs + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) - sngl(vs))/sngl(vs)
- endif
-
- enddo
- enddo
- enddo
- dvp = dvp / np
- dvs = dvs / np
- else
- dvp = 0.0
- dvs = 0.0
- endif
- endif
-
- ! top face
- ispecface = ispecface + 1
- write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(5)), &
- num_ibool_AVS_DX(iglobval(6)),num_ibool_AVS_DX(iglobval(7)), &
- num_ibool_AVS_DX(iglobval(8))
- if(ISOTROPIC_3D_MANTLE) write(11,*) ispecface,dvp,dvs
-
- endif
- enddo
-
-! check that number of surface elements output is okay
- if(ispecface /= nspecface) &
- call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation')
-
- close(10)
- if(ISOTROPIC_3D_MANTLE) close(11)
-
- end subroutine write_AVS_DX_surface_data
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/write_c_binary.c
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_c_binary.c 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_c_binary.c 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,651 +0,0 @@
-/*
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! December 2010
-!
-! 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.
-!
-!=====================================================================
-*/
-
-// after Brian's function
-
-#include "config.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include <unistd.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <fcntl.h>
-
-static int fd;
-
-void
-FC_FUNC_(open_file_create,OPEN_FILE)(char *file) {
- /* fprintf(stderr, "Opening file: %s\n", file); */
- fd = open(file, O_WRONLY | O_CREAT | O_TRUNC, 0644);
- if(fd == -1) {
- fprintf(stderr, "Error opening file: %s exiting\n", file);
- exit(-1);
- }
-}
-
-void
-FC_FUNC_(open_file_append,OPEN_FILE)(char *file) {
- /* fprintf(stderr, "Opening file: %s\n", file); */
- fd = open(file, O_WRONLY | O_CREAT | O_APPEND, 0644);
- if(fd == -1) {
- fprintf(stderr, "Error opening file: %s exiting\n", file);
- exit(-1);
- }
-}
-
-void
-FC_FUNC_(close_file,CLOSE_FILE)() {
- /* fprintf(stderr, "Closing file\n"); */
- close(fd);
-}
-
-void
-FC_FUNC_(write_integer,WRITE_INTEGER)(int *z) {
- int dummy_unused_variable = write(fd, z, sizeof(int));
-}
-
-void
-FC_FUNC_(write_real,WRITE_REAL)(float *z) {
- int dummy_unused_variable = write(fd, z, sizeof(float));
-}
-
-/* BS BS begin. Added section for writing SAC binary data*/
-void
-FC_FUNC_(write_n_real,WRITE_N_REAL)(float *z,int *n) {
- int dummy_unused_variable = write(fd, z, *n*sizeof(float));
-}
-
-void
-FC_FUNC_(write_character,WRITE_CHARACTER)(char *z, int *lchar) {
- int dummy_unused_variable = write(fd, z, *lchar*sizeof(char));
-}
-
-// LQY -- added for combine_vol/surf_data to write multiple binary files simultaneously --
-
-void
-FC_FUNC_(open_file_fd,OPEN_FILE_FD)(char *file, int *pfd) {
- /* fprintf(stderr, "Opening file: %s\n", file); */
- *pfd = open(file, O_WRONLY | O_CREAT, 0644);
- if(*pfd == -1) {
- fprintf(stderr, "Error opening file: %s exiting\n", file);
- exit(-1);
- }
-}
-
-void
-FC_FUNC_(close_file_fd,CLOSE_FILE_FD)(int *pfd) {
- /* fprintf(stderr, "Closing file\n"); */
- close(*pfd);
-}
-
-void
-FC_FUNC_(write_integer_fd,WRITE_INTEGER_FD)(int *pfd, int *z) {
- int dummy_unused_variable = write(*pfd, z, sizeof(int));
-}
-
-void
-FC_FUNC_(write_real_fd,WRITE_REAL_FD)(int *pfd, float *z) {
- int dummy_unused_variable = write(*pfd, z, sizeof(float));
-}
-
-/* BS BS begin. Added section for writing SAC binary data*/
-void
-FC_FUNC_(write_n_real_fd,WRITE_N_REAL_FD)(int *pfd, float *z,int *n) {
- int dummy_unused_variable = write(*pfd, z, *n*sizeof(float));
-}
-
-void
-FC_FUNC_(write_character_fd,WRITE_CHARACTER_FD)(int *pfd, char *z, int *lchar) {
- int dummy_unused_variable = write(*pfd, z, *lchar*sizeof(char));
-}
-
-
-/* ---------------------------------------
-
- IO performance test
-
- Software Optimization for High Performance Computing: Creating Faster Applications
-
- By Isom L. Crawford and Kevin R. Wadleigh
- Jul 18, 2003
-
- - uses functions fopen/fread/fwrite for binary file I/O
-
- --------------------------------------- */
-
-#define __USE_GNU
-#include <string.h>
-#include <regex.h>
-
-#define MIN(x,y) ((x) < (y) ? (x) : (y))
-
-/* fastest performance on nehalem nodes:
-
-Linux 2.6.18-164.11.1.el5 #1 SMP Wed Jan 20 10:04:55 EST 2010 x86_64 x86_64 x86_64 GNU/Linux
-
-achieved with 16 KB buffers: */
-
-//#define MAX_B 65536 // 64 KB
-//#define MAX_B 32768 // 32 KB
-#define MAX_B 16384 // 16 KB
-//#define MAX_B 8192 // 8 KB
-
-// absorbing files: instead of passing file descriptor, we use the array index
-// first 0 - 3 indices for crust mantle files
-// last 4 - 8 indices for outer core files
-#define ABS_FILEID 9
-
-// file points
-static FILE * fp_abs[ABS_FILEID];
-// file work buffers
-static char * work_buffer[ABS_FILEID];
-
-
-//void
-//FC_FUNC_(open_file_abs_r_fbin,OPEN_FILE_ABS_R_FBIN)(int *fid, char *filename,int *length, int *filesize){
-void open_file_abs_r_fbin(int *fid, char *filename,int *length, int *filesize){
-
-// opens file for read access
-
-//This sequence assigns the MAX_B array work_buffer to the file pointer
-// to be used for its buffering. performance should benefit.
- char * fncopy;
- char * blank;
- FILE *ft;
-
- // checks filesize
- if( *filesize == 0 ){
- perror("Error file size for reading");
- exit(EXIT_FAILURE);
- }
-
- // Trim the file name.
- fncopy = strndup(filename, *length);
- blank = strchr(fncopy, ' ');
- if (blank != NULL) {
- fncopy[blank - fncopy] = '\0';
- }
-
- // opens file
- ft = fopen( fncopy, "r+" );
- if( ft == NULL ) { perror("fopen"); exit(-1); }
-
- // sets mode for full buffering
- work_buffer[*fid] = (char *)malloc(MAX_B);
- setvbuf( ft, work_buffer[*fid], _IOFBF, (size_t)MAX_B );
-
- // stores file index id fid: from 0 to 8
- fp_abs[*fid] = ft;
-
- free(fncopy);
-}
-
-//void
-//FC_FUNC_(open_file_abs_w_fbin,OPEN_FILE_ABS_W_FBIN)(int *fid, char *filename, int *length, int *filesize){
-void open_file_abs_w_fbin(int *fid, char *filename, int *length, int *filesize){
-
-// opens file for write access
-
- //This sequence assigns the MAX_B array work_buffer to the file pointer
- // to be used for its buffering. performance should benefit.
- char * fncopy;
- char * blank;
- FILE *ft;
-
- // checks filesize
- if( *filesize == 0 ){
- perror("Error file size for reading");
- exit(EXIT_FAILURE);
- }
-
- // Trim the file name.
- fncopy = strndup(filename, *length);
- blank = strchr(fncopy, ' ');
- if (blank != NULL) {
- fncopy[blank - fncopy] = '\0';
- }
-
- // opens file
- ft = fopen( fncopy, "w+" );
- if( ft == NULL ) { perror("fopen"); exit(-1); }
-
- // sets mode for full buffering
- work_buffer[*fid] = (char *)malloc(MAX_B);
- setvbuf( ft, work_buffer[*fid], _IOFBF, (size_t)MAX_B );
-
- // stores file index id fid: from 0 to 8
- fp_abs[*fid] = ft;
-
- free(fncopy);
-
-}
-
-//void
-//FC_FUNC_(close_file_abs_fbin,CLOSE_FILE_ABS_FBIN)(int * fid){
-void close_file_abs_fbin(int * fid){
-
-// closes file
-
- fclose(fp_abs[*fid]);
-
- free(work_buffer[*fid]);
-
-}
-
-//void
-//FC_FUNC_(write_abs_fbin,WRITE_ABS_FBIN)(int *fid, void *buffer, int *length, int *index){
-void write_abs_fbin(int *fid, void *buffer, int *length, int *index){
-
-// writes binary file data in chunks of MAX_B
-
- FILE *ft;
- int itemlen,remlen,donelen,ret;
- void *buf;
-
- // file pointer
- ft = fp_abs[*fid];
-
- donelen = 0;
- remlen = *length;
- buf = buffer;
- ret = 0;
-
- //float dat[2];
- //memcpy(dat,buffer,*length);
- //printf("buffer: %f %f\n",dat[0],dat[1]);
-
- // writes items of maximum MAX_B to the file
- while (remlen > 0){
-
- itemlen = MIN(remlen,MAX_B);
- ret = fwrite(buf,1,itemlen,ft);
- if (ret > 0){
- donelen = donelen + ret;
- remlen = remlen - MAX_B;
- buf += MAX_B;
- }
- else{
- remlen = 0;
- }
- }
-
-}
-
-//void
-//FC_FUNC_(read_abs_fbin,READ_ABS_FBIN)(int *fid, void *buffer, int *length, int *index){
-void read_abs_fbin(int *fid, void *buffer, int *length, int *index){
-
-// reads binary file data in chunks of MAX_B
-
- FILE *ft;
- int ret,itemlen,remlen,donelen,pos;
- void *buf;
-
- // file pointer
- ft = fp_abs[*fid];
-
- // positions file pointer (for reverse time access)
- pos = (*length) * (*index -1 );
- fseek(ft, pos , SEEK_SET);
-
- donelen = 0;
- remlen = *length;
- buf = buffer;
- ret = 0;
-
- // reads items of maximum MAX_B to the file
- while (remlen > 0){
-
- // checks end of file
- if (ferror(ft) || feof(ft)) return;
-
- itemlen = MIN(remlen,MAX_B);
- ret = fread(buf,1,itemlen,ft);
-
- if (ferror(ft) || feof(ft)) return;
-
- if (ret > 0){
- donelen = donelen + ret;
- remlen = remlen - MAX_B;
- buf += MAX_B;
- }
- else{
- remlen = 0;
- }
- }
-
- //float dat[2];
- //memcpy(dat,buffer,*length);
- //printf("return buffer: %f %f\n",dat[0],dat[1]);
-}
-
-
-
-
-/* ---------------------------------------
-
- IO performance test
-
-
-A Performance Comparison of "read" and "mmap" in the Solaris 8 OS
-
-By Oyetunde Fadele, September 2002
-
-http://developers.sun.com/solaris/articles/read_mmap.html
-
-or
-
-High-performance network programming, Part 2: Speed up processing at both the client and server
-
-by Girish Venkatachalam
-
-http://www.ibm.com/developerworks/aix/library/au-highperform2/
-
-
- - uses functions mmap/memcpy for mapping file I/O
-
-------------------------------------- */
-
-
-#include <errno.h>
-#include <limits.h>
-#include <sys/mman.h>
-
-// file maps
-static char * map_abs[ABS_FILEID];
-// file descriptors
-static int map_fd_abs[ABS_FILEID];
-// file sizes
-static int filesize_abs[ABS_FILEID];
-
-//void
-//FC_FUNC_(open_file_abs_w_map,OPEN_FILE_ABS_W_MAP)(int *fid, char *filename, int *length, int *filesize){
-void open_file_abs_w_map(int *fid, char *filename, int *length, int *filesize){
-
-// opens file for write access
-
- int ft;
- int result;
- char *map;
- char *fncopy;
- char *blank;
-
- // checks filesize
- if( *filesize == 0 ){
- perror("Error file size for writing");
- exit(EXIT_FAILURE);
- }
-
- // Trim the file name.
- fncopy = strndup(filename, *length);
- blank = strchr(fncopy, ' ');
- if (blank != NULL) {
- fncopy[blank - fncopy] = '\0';
- }
-
- /* Open a file for writing.
- * - Creating the file if it doesn't exist.
- * - Truncating it to 0 size if it already exists. (not really needed)
- *
- * Note: "O_WRONLY" mode is not sufficient when mmaping.
- */
- ft = open(fncopy, O_RDWR | O_CREAT | O_TRUNC, (mode_t)0600);
- if (ft == -1) {
- perror("Error opening file for writing");
- exit(EXIT_FAILURE);
- }
-
- // file index id fid: from 0 to 8
- map_fd_abs[*fid] = ft;
-
- free(fncopy);
-
-
- /* Stretch the file size to the size of the (mmapped) array of ints
- */
- filesize_abs[*fid] = *filesize;
- result = lseek(ft, filesize_abs[*fid] - 1, SEEK_SET);
- if (result == -1) {
- close(ft);
- perror("Error calling fseek() to 'stretch' the file");
- exit(EXIT_FAILURE);
- }
-
- //printf("file length: %d \n",filesize_abs[*fid]);
-
-
- /* Something needs to be written at the end of the file to
- * have the file actually have the new size.
- * Just writing an empty string at the current file position will do.
- *
- * Note:
- * - The current position in the file is at the end of the stretched
- * file due to the call to lseek().
- * - An empty string is actually a single '\0' character, so a zero-byte
- * will be written at the last byte of the file.
- */
- result = write(ft, "", 1);
- if (result != 1) {
- close(ft);
- perror("Error writing last byte of the file");
- exit(EXIT_FAILURE);
- }
-
- /* Now the file is ready to be mmapped.
- */
- map = mmap(0, filesize_abs[*fid], PROT_READ | PROT_WRITE, MAP_SHARED, ft, 0);
- if (map == MAP_FAILED) {
- close(ft);
- perror("Error mmapping the file");
- exit(EXIT_FAILURE);
- }
-
- map_abs[*fid] = map;
-
- //printf("file map: %d\n",*fid);
-
-}
-
-//void
-//FC_FUNC_(open_file_abs_r_map,OPEN_FILE_ABS_R_MAP)(int *fid, char *filename,int *length, int *filesize){
-void open_file_abs_r_map(int *fid, char *filename,int *length, int *filesize){
-
- // opens file for read access
- char * fncopy;
- char * blank;
- int ft;
- char *map;
-
- // checks filesize
- if( *filesize == 0 ){
- perror("Error file size for reading");
- exit(EXIT_FAILURE);
- }
-
- // Trim the file name.
- fncopy = strndup(filename, *length);
- blank = strchr(fncopy, ' ');
- if (blank != NULL) {
- fncopy[blank - fncopy] = '\0';
- }
-
-
- ft = open(fncopy, O_RDONLY);
- if (ft == -1) {
- perror("Error opening file for reading");
- exit(EXIT_FAILURE);
- }
-
- // file index id fid: from 0 to 8
- map_fd_abs[*fid] = ft;
-
- free(fncopy);
-
- filesize_abs[*fid] = *filesize;
-
- map = mmap(0, filesize_abs[*fid], PROT_READ, MAP_SHARED, ft, 0);
- if (map == MAP_FAILED) {
- close(ft);
- perror("Error mmapping the file");
- exit(EXIT_FAILURE);
- }
-
- map_abs[*fid] = map;
-
- //printf("file length r: %d \n",filesize_abs[*fid]);
- //printf("file map r: %d\n",*fid);
-
-}
-
-
-//void
-//FC_FUNC_(close_file_abs_map,CLOSE_FILE_ABS_MAP)(int * fid){
-void close_file_abs_map(int * fid){
-
- /* Don't forget to free the mmapped memory
- */
- if (munmap(map_abs[*fid], filesize_abs[*fid]) == -1) {
- perror("Error un-mmapping the file");
- /* Decide here whether to close(fd) and exit() or not. Depends... */
- }
-
- /* Un-mmaping doesn't close the file, so we still need to do that.
- */
- close(map_fd_abs[*fid]);
-}
-
-
-//void
-//FC_FUNC_(write_abs_map,WRITE_ABS_MAP)(int *fid, char *buffer, int *length , int *index){
-void write_abs_map(int *fid, char *buffer, int *length , int *index){
-
- char *map;
- int offset;
-
- map = map_abs[*fid];
-
- // offset in bytes
- offset = (*index -1 ) * (*length) ;
-
- // copies buffer to map
- memcpy( &map[offset], buffer ,*length );
-
-}
-
-//void
-//FC_FUNC_(read_abs_map,READ_ABS_MAP)(int *fid, char *buffer, int *length , int *index){
-void read_abs_map(int *fid, char *buffer, int *length , int *index){
-
- char *map;
- int offset;
-
- map = map_abs[*fid];
-
- // offset in bytes
- offset = (*index -1 ) * (*length) ;
-
- // copies map to buffer
- memcpy( buffer, &map[offset], *length );
-
-}
-
-
-/*
-
-wrapper functions
-
-- for your preferred, optimized file i/o ;
- e.g. uncomment // #define USE_MAP... in config.h to use mmap routines
- or comment out (default) to use fopen/fwrite/fread functions
-
- note: mmap functions should work fine for local harddisk directories, but can lead to
- problems with global (e.g. NFS) directories
-
- (on nehalem, Linux 2.6.18-164.11.1.el5 #1 SMP Wed Jan 20 10:04:55 EST 2010 x86_64 x86_64 x86_64 GNU/Linux
- - mmap functions are about 20 % faster than conventional fortran, unformatted file i/o
- - fwrite/fread function are about 12 % faster than conventional fortran, unformatted file i/o )
-
-*/
-
-void
-FC_FUNC_(open_file_abs_w,OPEN_FILE_ABS_W)(int *fid, char *filename,int *length, int *filesize) {
-
-#ifdef USE_MAP_FUNCTION
- open_file_abs_w_map(fid,filename,length,filesize);
-#else
- open_file_abs_w_fbin(fid,filename,length,filesize);
-#endif
-
-}
-
-void
-FC_FUNC_(open_file_abs_r,OPEN_FILE_ABS_R)(int *fid, char *filename,int *length, int *filesize) {
-
-#ifdef USE_MAP_FUNCTION
- open_file_abs_r_map(fid,filename,length,filesize);
-#else
- open_file_abs_r_fbin(fid,filename,length,filesize);
-#endif
-
-}
-
-void
-FC_FUNC_(close_file_abs,CLOSE_FILES_ABS)(int *fid) {
-
-#ifdef USE_MAP_FUNCTION
- close_file_abs_map(fid);
-#else
- close_file_abs_fbin(fid);
-#endif
-
-}
-
-void
-FC_FUNC_(write_abs,WRITE_ABS)(int *fid, char *buffer, int *length , int *index) {
-
-#ifdef USE_MAP_FUNCTION
- write_abs_map(fid,buffer,length,index);
-#else
- write_abs_fbin(fid,buffer,length,index);
-#endif
-
-}
-
-void
-FC_FUNC_(read_abs,READ_ABS)(int *fid, char *buffer, int *length , int *index) {
-
-#ifdef USE_MAP_FUNCTION
- read_abs_map(fid,buffer,length,index);
-#else
- read_abs_fbin(fid,buffer,length,index);
-#endif
-
-}
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_surface.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_surface.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_surface.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,123 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- store_val_x,store_val_y,store_val_z, &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux,store_val_uy,store_val_uz, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all, &
- ibelm_top_crust_mantle,ibool_crust_mantle,nspec_top, &
- NIT,it,OUTPUT_FILES)
-
- implicit none
-
- include 'mpif.h'
- include "precision.h"
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer myrank,nmovie_points
- double precision :: scale_veloc
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- veloc_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(nmovie_points) :: &
- store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz
-
- real(kind=CUSTOM_REAL), dimension(nmovie_points,0:NPROCTOT_VAL-1) :: &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all
-
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- integer nspec_top,NIT,it
- character(len=150) OUTPUT_FILES
-
- ! local parameters
- character(len=150) :: outputname
- integer :: ipoin,ispec2D,ispec,i,j,k,ier,iglob
-
- ! save velocity here to avoid static offset on displacement for movies
-
-
- ! get coordinates of surface mesh and surface displacement
- ipoin = 0
- do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
- ispec = ibelm_top_crust_mantle(ispec2D)
-
- ! in case of global, NCHUNKS_VAL == 6 simulations, be aware that for
- ! the cubed sphere, the mapping changes for different chunks,
- ! i.e. e.g. x(1,1) and x(5,5) flip left and right sides of the elements in geographical coordinates.
- ! for future consideration, like in create_movie_GMT_global.f90 ...
- k = NGLLZ
-
- ! loop on all the points inside the element
- do j = 1,NGLLY,NIT
- do i = 1,NGLLX,NIT
- ipoin = ipoin + 1
- iglob = ibool_crust_mantle(i,j,k,ispec)
- store_val_x(ipoin) = xstore_crust_mantle(iglob)
- store_val_y(ipoin) = ystore_crust_mantle(iglob)
- store_val_z(ipoin) = zstore_crust_mantle(iglob)
- store_val_ux(ipoin) = veloc_crust_mantle(1,iglob)*scale_veloc
- store_val_uy(ipoin) = veloc_crust_mantle(2,iglob)*scale_veloc
- store_val_uz(ipoin) = veloc_crust_mantle(3,iglob)*scale_veloc
- enddo
- enddo
-
- enddo
-
- ! gather info on master proc
- ispec = nmovie_points
- call MPI_GATHER(store_val_x,ispec,CUSTOM_MPI_TYPE,store_val_x_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_y,ispec,CUSTOM_MPI_TYPE,store_val_y_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_z,ispec,CUSTOM_MPI_TYPE,store_val_z_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_ux,ispec,CUSTOM_MPI_TYPE,store_val_ux_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_uy,ispec,CUSTOM_MPI_TYPE,store_val_uy_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_uz,ispec,CUSTOM_MPI_TYPE,store_val_uz_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
-
- ! save movie data to disk in home directory
- if(myrank == 0) then
- write(outputname,"('/moviedata',i6.6)") it
- open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted',action='write')
- write(IOUT) store_val_x_all
- write(IOUT) store_val_y_all
- write(IOUT) store_val_z_all
- write(IOUT) store_val_ux_all
- write(IOUT) store_val_uy_all
- write(IOUT) store_val_uz_all
- close(IOUT)
- endif
-
- end subroutine write_movie_surface
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_volume.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_volume.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_volume.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,543 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! create file OUTPUT_FILES/values_from_mesher.h based upon DATA/Par_file
-! in order to compile the solver with the right array sizes
-
-!---------------------------------------------------------------------------------
-! this subroutine counts the number of points and elements within the movie volume
-! in this processor slice, and returns arrays that keep track of them, both in global and local indexing schemes
-
- subroutine count_points_movie_volume(prname,ibool_crust_mantle, xstore_crust_mantle,ystore_crust_mantle, &
- zstore_crust_mantle,MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- MOVIE_COARSE,npoints_3dmovie,nspecel_3dmovie,num_ibool_3dmovie, &
- mask_ibool_3dmovie,mask_3dmovie)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
-! input
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
- double precision :: MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
- logical :: MOVIE_COARSE
- character(len=150) :: prname
-
-! output
- integer :: npoints_3dmovie,nspecel_3dmovie
- integer, dimension(NGLOB_CRUST_MANTLE) :: num_ibool_3dmovie
- logical, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool_3dmovie
- logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
-
-! variables
- integer :: ipoints_3dmovie,ispecel_3dmovie,ispec,iglob,i,j,k,NIT
- real(kind=custom_real) :: rval,thetaval,phival
-
- if(MOVIE_COARSE) then
- NIT = NGLLX-1
- else
- NIT = 1
- endif
- ipoints_3dmovie=0
- num_ibool_3dmovie(:) = -99
- ispecel_3dmovie = 0
- mask_ibool_3dmovie(:)=.false.
- mask_3dmovie(:,:,:,:)=.false.
- ! create name of database
- open(unit=IOUT,file=trim(prname)//'movie3D_info.txt',status='unknown')
-
- !find and count points within given region for storing movie
- do ispec = 1,NSPEC_CRUST_MANTLE
- !output element if center of element is in the given region
- iglob = ibool_crust_mantle((NGLLX+1)/2,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
- rval = xstore_crust_mantle(iglob)
- thetaval = ystore_crust_mantle(iglob)
- phival = zstore_crust_mantle(iglob)
- ! we alread changed xyz back to rthetaphi
- if( (rval < MOVIE_TOP .and. rval > MOVIE_BOTTOM) .and. &
- (thetaval > MOVIE_NORTH .and. thetaval < MOVIE_SOUTH) .and. &
- ( (phival < MOVIE_EAST .and. phival > MOVIE_WEST) .or. &
- ( (MOVIE_EAST < MOVIE_WEST) .and. (phival >MOVIE_EAST .or. phival < MOVIE_WEST) ) ) ) then
- ispecel_3dmovie=ispecel_3dmovie+1
- do k=1,NGLLZ,NIT
- do j=1,NGLLY,NIT
- do i=1,NGLLX,NIT
- iglob = ibool_crust_mantle(i,j,k,ispec)
- if(.not. mask_ibool_3dmovie(iglob)) then
- ipoints_3dmovie = ipoints_3dmovie + 1
- mask_ibool_3dmovie(iglob)=.true.
- mask_3dmovie(i,j,k,ispec)=.true.
- num_ibool_3dmovie(iglob)= ipoints_3dmovie
- endif
- enddo !i
- enddo !j
- enddo !k
- endif !in region
- enddo !ispec
- npoints_3dmovie=ipoints_3dmovie
- nspecel_3dmovie=ispecel_3dmovie
-
- write(IOUT,*) npoints_3dmovie, nspecel_3dmovie
- close(IOUT)
-
- end subroutine count_points_movie_volume
-
-! -----------------------------------------------------------------
-! writes meshfiles to merge with solver snapshots for 3D volume movies. Also computes and outputs
-! the rotation matrix nu_3dmovie required to transfer to a geographic coordinate system
-
- subroutine write_movie_volume_mesh(npoints_3dmovie,prname,ibool_crust_mantle,xstore_crust_mantle, &
- ystore_crust_mantle,zstore_crust_mantle, muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,mask_ibool_3dmovie,num_ibool_3dmovie,nu_3dmovie,MOVIE_COARSE)
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- !input
- integer :: npoints_3dmovie
- integer, dimension(NGLOB_CRUST_MANTLE) :: num_ibool_3dmovie
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: muvstore_crust_mantle_3dmovie
- character(len=150) :: prname
- logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
- logical, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool_3dmovie
- logical :: MOVIE_COARSE
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- !output
- real(kind=CUSTOM_REAL), dimension(3,3,npoints_3dmovie) :: nu_3dmovie
- real(kind=CUSTOM_REAL), dimension(npoints_3dmovie) :: store_val3D_mu
-
- !variables
- integer :: ipoints_3dmovie,ispecele,ispec,i,j,k,iglob,iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
- integer :: n1,n2,n3,n4,n5,n6,n7,n8,NIT
- real(kind=CUSTOM_REAL) :: rval,thetaval,phival,xval,yval,zval,st,ct,sp,cp
- real(kind=CUSTOM_REAL), dimension(npoints_3dmovie) :: store_val3D_x,store_val3D_y, store_val3D_z
-
- if(NDIM /= 3) stop 'movie volume output requires NDIM = 3'
-
- if(MOVIE_COARSE) then
- NIT = NGLLX-1
- else
- NIT = 1
- endif
-
- ipoints_3dmovie=0
- do ispec=1,NSPEC_CRUST_MANTLE
- do k=1,NGLLZ,NIT
- do j=1,NGLLY,NIT
- do i=1,NGLLX,NIT
- if(mask_3dmovie(i,j,k,ispec)) then
- ipoints_3dmovie=ipoints_3dmovie+1
- iglob= ibool_crust_mantle(i,j,k,ispec)
- rval = xstore_crust_mantle(iglob)
- thetaval = ystore_crust_mantle(iglob)
- phival = zstore_crust_mantle(iglob)
-!x,y,z store have been converted to r theta phi already, need to revert back for xyz output
- call rthetaphi_2_xyz(xval,yval,zval,rval,thetaval,phival)
- store_val3D_x(ipoints_3dmovie)=xval
- store_val3D_y(ipoints_3dmovie)=yval
- store_val3D_z(ipoints_3dmovie)=zval
- store_val3D_mu(ipoints_3dmovie)=muvstore_crust_mantle_3dmovie(i,j,k,ispec)
- st = sin(thetaval)
- ct = cos(thetaval)
- sp = sin(phival)
- cp = cos(phival)
- nu_3dmovie(1,1,ipoints_3dmovie)=-ct*cp
- nu_3dmovie(1,2,ipoints_3dmovie)=-ct*sp
- nu_3dmovie(1,3,ipoints_3dmovie)=st
- nu_3dmovie(2,1,ipoints_3dmovie)=-sp
- nu_3dmovie(2,2,ipoints_3dmovie)=cp
- nu_3dmovie(2,3,ipoints_3dmovie)=0.d0
- nu_3dmovie(3,1,ipoints_3dmovie)=st*cp
- nu_3dmovie(3,2,ipoints_3dmovie)=st*sp
- nu_3dmovie(3,3,ipoints_3dmovie)=ct
- endif !mask_3dmovie
- enddo !i
- enddo !j
- enddo !k
- enddo !ispec
- open(unit=IOUT,file=trim(prname)//'movie3D_x.bin',status='unknown',form='unformatted')
- if(npoints_3dmovie>0) then
- write(IOUT) store_val3D_x(1:npoints_3dmovie)
- endif
- close(IOUT)
- open(unit=IOUT,file=trim(prname)//'movie3D_y.bin',status='unknown',form='unformatted')
- if(npoints_3dmovie>0) then
- write(IOUT) store_val3D_y(1:npoints_3dmovie)
- endif
- close(IOUT)
-
- open(unit=IOUT,file=trim(prname)//'movie3D_z.bin',status='unknown',form='unformatted')
- if(npoints_3dmovie>0) then
- write(IOUT) store_val3D_z(1:npoints_3dmovie)
- endif
- close(IOUT)
-
- open(unit=IOUT,file=trim(prname)//'ascii_output.txt',status='unknown')
- if(npoints_3dmovie>0) then
- do i=1,npoints_3dmovie
- write(IOUT,*) store_val3D_x(i),store_val3D_y(i),store_val3D_z(i),store_val3D_mu(i)
- enddo
- endif
- close(IOUT)
- open(unit=IOUT,file=trim(prname)//'movie3D_elements.bin',status='unknown',form='unformatted')
- ispecele=0
- ! open(unit=IOUT,file=trim(prname)//'movie3D_elements.txt',status='unknown')
- do ispec=1,NSPEC_CRUST_MANTLE
- if(MOVIE_COARSE) then
- iglob=ibool_crust_mantle(1,1,1,ispec)
- else
- iglob=ibool_crust_mantle(3,3,3,ispec)
- endif
- if(mask_ibool_3dmovie(iglob)) then !this element is in the region
- ispecele = ispecele+1
- do k=1,NGLLZ-1,NIT
- do j=1,NGLLY-1,NIT
- do i=1,NGLLX-1,NIT
- ! if(mask_3dmovie(i,j,k,ispec)) then
- iglob1 = ibool_crust_mantle(i,j,k,ispec)
- iglob2 = ibool_crust_mantle(i+NIT,j,k,ispec)
- iglob3 = ibool_crust_mantle(i+NIT,j+NIT,k,ispec)
- iglob4 = ibool_crust_mantle(i,j+NIT,k,ispec)
- iglob5 = ibool_crust_mantle(i,j,k+NIT,ispec)
- iglob6 = ibool_crust_mantle(i+NIT,j,k+NIT,ispec)
- iglob7 = ibool_crust_mantle(i+NIT,j+NIT,k+NIT,ispec)
- iglob8 = ibool_crust_mantle(i,j+NIT,k+NIT,ispec)
- n1 = num_ibool_3dmovie(iglob1)-1
- n2 = num_ibool_3dmovie(iglob2)-1
- n3 = num_ibool_3dmovie(iglob3)-1
- n4 = num_ibool_3dmovie(iglob4)-1
- n5 = num_ibool_3dmovie(iglob5)-1
- n6 = num_ibool_3dmovie(iglob6)-1
- n7 = num_ibool_3dmovie(iglob7)-1
- n8 = num_ibool_3dmovie(iglob8)-1
- write(IOUT) n1,n2,n3,n4,n5,n6,n7,n8
- ! write(57,*) n1,n2,n3,n4,n5,n6,n7,n8
- ! endif !mask3dmovie
- enddo !i
- enddo !j
- enddo !k
- endif
- enddo !ispec
- close(IOUT)
-! close(57)
- end subroutine write_movie_volume_mesh
-
-! ---------------------------------------------
-
- subroutine write_movie_volume_strains(myrank,npoints_3dmovie,LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle,muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
-
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- ! input
- integer :: myrank,npoints_3dmovie,MOVIE_VOLUME_TYPE,it
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: eps_trace_over_3_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: muvstore_crust_mantle_3dmovie
- logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
- logical :: MOVIE_COARSE
- real(kind=CUSTOM_REAL), dimension(3,3,npoints_3dmovie) :: nu_3dmovie
- character(len=150) LOCAL_PATH,outputname
-
- ! variables
- character(len=150) prname
- integer :: ipoints_3dmovie,i,j,k,ispec,NIT
- real(kind=CUSTOM_REAL) :: muv_3dmovie
- real(kind=CUSTOM_REAL),dimension(3,3) :: eps_loc,eps_loc_new
- real(kind=CUSTOM_REAL),dimension(:),allocatable :: store_val3d_NN,store_val3d_EE,store_val3d_ZZ,&
- store_val3d_NE,store_val3d_NZ,store_val3d_EZ
-
- character(len=1) movie_prefix
-
- allocate(store_val3d_NN(npoints_3dmovie))
- allocate(store_val3d_EE(npoints_3dmovie))
- allocate(store_val3d_ZZ(npoints_3dmovie))
- allocate(store_val3d_NE(npoints_3dmovie))
- allocate(store_val3d_NZ(npoints_3dmovie))
- allocate(store_val3d_EZ(npoints_3dmovie))
-
- if(NDIM /= 3) call exit_MPI(myrank, 'write_movie_volume requires NDIM = 3')
-
- if(MOVIE_VOLUME_TYPE == 1) then
- movie_prefix='E' ! strain
- else if(MOVIE_VOLUME_TYPE == 2) then
- movie_prefix='S' ! time integral of strain
- else if(MOVIE_VOLUME_TYPE == 3) then
- movie_prefix='P' ! potency, or integral of strain x \mu
- endif
- if(MOVIE_COARSE) then
- NIT = NGLLX-1
- else
- NIT = 1
- endif
-
- write(prname,"('proc',i6.6)") myrank
- ipoints_3dmovie=0
- do ispec=1,NSPEC_CRUST_MANTLE
- do k=1,NGLLZ,NIT
- do j=1,NGLLY,NIT
- do i=1,NGLLX,NIT
- if(mask_3dmovie(i,j,k,ispec)) then
- ipoints_3dmovie=ipoints_3dmovie+1
- muv_3dmovie=muvstore_crust_mantle_3dmovie(i,j,k,ispec)
- eps_loc(1,1)=eps_trace_over_3_crust_mantle(i,j,k,ispec) + epsilondev_crust_mantle(1,i,j,k,ispec)
- eps_loc(2,2)=eps_trace_over_3_crust_mantle(i,j,k,ispec) + epsilondev_crust_mantle(2,i,j,k,ispec)
- eps_loc(3,3)=eps_trace_over_3_crust_mantle(i,j,k,ispec)- &
- epsilondev_crust_mantle(1,i,j,k,ispec) - epsilondev_crust_mantle(2,i,j,k,ispec)
- eps_loc(1,2)=epsilondev_crust_mantle(3,i,j,k,ispec)
- eps_loc(1,3)=epsilondev_crust_mantle(4,i,j,k,ispec)
- eps_loc(2,3)=epsilondev_crust_mantle(5,i,j,k,ispec)
- eps_loc(2,1)=eps_loc(1,2)
- eps_loc(3,1)=eps_loc(1,3)
- eps_loc(3,2)=eps_loc(2,3)
-
- ! rotate eps_loc to spherical coordinates
- eps_loc_new(:,:) = matmul(matmul(nu_3dmovie(:,:,ipoints_3dmovie),eps_loc(:,:)), transpose(nu_3dmovie(:,:,ipoints_3dmovie)))
- if(MOVIE_VOLUME_TYPE == 3) eps_loc_new(:,:) = eps_loc(:,:)*muv_3dmovie
- store_val3d_NN(ipoints_3dmovie)=eps_loc_new(1,1)
- store_val3d_EE(ipoints_3dmovie)=eps_loc_new(2,2)
- store_val3d_ZZ(ipoints_3dmovie)=eps_loc_new(3,3)
- store_val3d_NE(ipoints_3dmovie)=eps_loc_new(1,2)
- store_val3d_NZ(ipoints_3dmovie)=eps_loc_new(1,3)
- store_val3d_EZ(ipoints_3dmovie)=eps_loc_new(2,3)
- endif
- enddo
- enddo
- enddo
- enddo
- if(ipoints_3dmovie /= npoints_3dmovie) stop 'did not find the right number of points for 3D movie'
-
- write(outputname,"('proc',i6.6,'_movie3D_',a,'NN',i6.6,'.bin')") myrank,movie_prefix,it
- open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
- write(27) store_val3d_NN(1:npoints_3dmovie)
- close(27)
-
- write(outputname,"('proc',i6.6,'_movie3D_',a,'EE',i6.6,'.bin')") myrank,movie_prefix,it
- open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
- write(27) store_val3d_EE(1:npoints_3dmovie)
- close(27)
-
- write(outputname,"('proc',i6.6,'_movie3D_',a,'ZZ',i6.6,'.bin')") myrank,movie_prefix,it
- open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
- write(27) store_val3d_ZZ(1:npoints_3dmovie)
- close(27)
-
- write(outputname,"('proc',i6.6,'_movie3D_',a,'NE',i6.6,'.bin')") myrank,movie_prefix,it
- open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
- write(27) store_val3d_NE(1:npoints_3dmovie)
- close(27)
-
-
- write(outputname,"('proc',i6.6,'_movie3D_',a,'NZ',i6.6,'.bin')") myrank,movie_prefix,it
- open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
- write(27) store_val3d_NZ(1:npoints_3dmovie)
- close(27)
-
- write(outputname,"('proc',i6.6,'_movie3D_',a,'EZ',i6.6,'.bin')") myrank,movie_prefix,it
- open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
- write(27) store_val3d_EZ(1:npoints_3dmovie)
- close(27)
-
- end subroutine write_movie_volume_strains
-
-! ---------------------------------------------
- subroutine write_movie_volume_vector(myrank,it,npoints_3dmovie,LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,vector_crust_mantle,scalingval,mask_3dmovie,nu_3dmovie)
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- ! input
- integer :: myrank,npoints_3dmovie,MOVIE_VOLUME_TYPE,it
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- real(kind=CUSTOM_REAL), dimension(3,NGLOB_CRUST_MANTLE) :: vector_crust_mantle,vector_scaled
- real(kind=CUSTOM_REAL), dimension(3,3,npoints_3dmovie) :: nu_3dmovie
- double precision :: scalingval
- real(kind=CUSTOM_REAL), dimension(3) :: vector_local,vector_local_new
- logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
- logical :: MOVIE_COARSE
- character(len=150) LOCAL_PATH
-
- ! variables
- integer :: ipoints_3dmovie,i,j,k,ispec,NIT,iglob
- real(kind=CUSTOM_REAL),dimension(:),allocatable :: store_val3d_N,store_val3d_E,store_val3d_Z
- character(len=150) outputname
- character(len=2) movie_prefix
-
- if(NDIM /= 3) call exit_MPI(myrank,'write_movie_volume requires NDIM = 3')
-
- allocate(store_val3d_N(npoints_3dmovie))
- allocate(store_val3d_E(npoints_3dmovie))
- allocate(store_val3d_Z(npoints_3dmovie))
-
- if(MOVIE_VOLUME_TYPE == 5) then
- movie_prefix='DI' ! displacement
- else if(MOVIE_VOLUME_TYPE == 6) then
- movie_prefix='VE' ! velocity
- endif
- if(MOVIE_COARSE) then
- NIT = NGLLX-1
- else
- NIT = 1
- endif
-
- if(CUSTOM_REAL == SIZE_REAL) then
- vector_scaled = vector_crust_mantle*sngl(scalingval)
- else
- vector_scaled = vector_crust_mantle*scalingval
- endif
-
- ipoints_3dmovie=0
- do ispec=1,NSPEC_CRUST_MANTLE
- do k=1,NGLLZ,NIT
- do j=1,NGLLY,NIT
- do i=1,NGLLX,NIT
- if(mask_3dmovie(i,j,k,ispec)) then
- ipoints_3dmovie=ipoints_3dmovie+1
- iglob = ibool_crust_mantle(i,j,k,ispec)
- vector_local(:) = vector_scaled(:,iglob)
-
- ! rotate eps_loc to spherical coordinates
- vector_local_new(:) = matmul(nu_3dmovie(:,:,ipoints_3dmovie), vector_local(:))
- store_val3d_N(ipoints_3dmovie)=vector_local_new(1)
- store_val3d_E(ipoints_3dmovie)=vector_local_new(2)
- store_val3d_Z(ipoints_3dmovie)=vector_local_new(3)
- endif
- enddo
- enddo
- enddo
- enddo
- close(IOUT)
- if(ipoints_3dmovie /= npoints_3dmovie) stop 'did not find the right number of points for 3D movie'
-
- write(outputname,"('proc',i6.6,'_movie3D_',a,'N',i6.6,'.bin')") myrank,movie_prefix,it
- open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
- write(27) store_val3d_N(1:npoints_3dmovie)
- close(27)
-
- write(outputname,"('proc',i6.6,'_movie3D_',a,'E',i6.6,'.bin')") myrank,movie_prefix,it
- open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
- write(27) store_val3d_E(1:npoints_3dmovie)
- close(27)
-
- write(outputname,"('proc',i6.6,'_movie3D_',a,'Z',i6.6,'.bin')") myrank,movie_prefix,it
- open(unit=27,file=trim(LOCAL_PATH)//'/'//trim(outputname),status='unknown',form='unformatted')
- write(27) store_val3d_Z(1:npoints_3dmovie)
- close(27)
-
-
- end subroutine write_movie_volume_vector
-
-!--------------------
-
- subroutine write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
- accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
- eps_trace_over_3_inner_core,epsilondev_crust_mantle,&
- epsilondev_inner_core)
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
- ! div
- integer :: myrank,it,ispec,iglob,i,j,k
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: epsilondev_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STRAIN_ONLY) :: eps_trace_over_3_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: rhostore_outer_core, &
- kappavstore_outer_core,ibool_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: eps_trace_over_3_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev_crust_mantle
- real(kind=CUSTOM_REAL) :: rhol,kappal
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: div_s_outer_core
-
- character(len=150) LOCAL_PATH,outputname
-
-
- write(outputname,"('proc',i6.6,'_crust_mantle_div_displ_it',i6.6,'.bin')") myrank,it
- open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- write(27) eps_trace_over_3_crust_mantle
- close(27)
-
-! we use div s = - p / kappa = rhostore_outer_core * accel_outer_core / kappavstore_outer_core
- allocate(div_s_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT))
- do ispec = 1, NSPEC_OUTER_CORE
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool_outer_core(i,j,k,ispec)
- rhol = rhostore_outer_core(i,j,k,ispec)
- kappal = kappavstore_outer_core(i,j,k,ispec)
- div_s_outer_core(i,j,k,ispec) = rhol * accel_outer_core(iglob) / kappal
- enddo
- enddo
- enddo
- enddo
-
- write(outputname,"('proc',i6.6,'_outer_core_div_displ_it',i6.6,'.bin')") myrank,it
- open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- write(27) div_s_outer_core
- close(27)
-
- deallocate(div_s_outer_core)
-
-
- ! write(outputname,"('proc',i6.6,'_outer_core_div_displ_it',i6.6,'.bin')") myrank,it
- ! open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- ! write(27) ONE_THIRD * div_displ_outer_core
- ! close(27)
-
- write(outputname,"('proc',i6.6,'_inner_core_div_displ_proc_it',i6.6,'.bin')") myrank,it
- open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- write(27) eps_trace_over_3_inner_core
- close(27)
-
-! epsilondev
-
- write(outputname,"('proc',i6.6,'_crust_mantle_epsdev_displ_it',i6.6,'.bin')") myrank,it
- open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- write(27) epsilondev_crust_mantle
- close(27)
-
- write(outputname,"('proc',i6.6,'inner_core_epsdev_displ_it',i6.6,'.bin')") myrank,it
- open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- write(27) epsilondev_inner_core
- close(27)
-
-
- end subroutine write_movie_volume_divcurl
-
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/write_output_ASCII.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_output_ASCII.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_output_ASCII.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,111 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine write_output_ASCII(seismogram_tmp, &
- DT,hdur,OUTPUT_FILES, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank, &
- iorientation,sisname,sisname_big_file)
-
-! 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
-
- implicit none
-
- include "constants.h"
-
- integer :: seismo_offset, seismo_current, NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
- real(kind=CUSTOM_REAL), dimension(5,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: seismogram_tmp
-
- integer myrank
- double precision hdur,DT
-
- integer iorientation
-
- character(len=256) sisname,sisname_big_file
- character(len=150) OUTPUT_FILES
-
- ! 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
-
- ! local parameters
- integer ier,isample
- character(len=256) sisname_2
- double precision value
-
-
- ! add .ascii extension to seismogram file name for ASCII seismograms
- write(sisname_2,"('/',a,'.ascii')") trim(sisname)
-
- ! create one large file instead of one small file per station to avoid file system overload
- if(SAVE_ALL_SEISMOS_IN_ONE_FILE) then
- if(USE_BINARY_FOR_LARGE_FILE) then
- write(IOUT) sisname_big_file
- else
- write(IOUT,*) sisname_big_file(1:len_trim(sisname_big_file))
- endif
- else
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2), &
- status='unknown',action='write',iostat=ier)
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2), &
- status='old',position='append',action='write',iostat=ier)
- endif
- if( ier /= 0 ) call exit_mpi(myrank,'error opening file:'//trim(OUTPUT_FILES)//trim(sisname_2))
- 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)
-
- end subroutine write_output_ASCII
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/write_output_SAC.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_output_SAC.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_output_SAC.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,631 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine write_output_SAC(seismogram_tmp,irec, &
- station_name,network_name,stlat,stlon,stele,stbur,nrec, &
- ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
- yr,jda,ho,mi,sec,tshift_cmt,t_shift,&
- elat,elon,depth,event_name,cmt_lat,cmt_lon,cmt_depth,cmt_hdur, &
- OUTPUT_FILES, &
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
- iorientation,phi,chn,sisname)
-
-! SAC headers have new format
-! by Ebru
-
- implicit none
-
- include "constants.h"
-
- integer nrec,it_end
-
- integer :: seismo_offset, seismo_current, NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
- real(kind=CUSTOM_REAL), dimension(5,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: seismogram_tmp
-
- integer NEX_XI
- double precision ANGULAR_WIDTH_XI_IN_DEGREES
-
- 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
- integer iorientation
-
- character(len=4) chn
- character(len=256) sisname
- character(len=150) OUTPUT_FILES
-
- double precision tshift_cmt,t_shift,elat,elon,depth
- double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
- double precision, dimension(nrec) :: stlat,stlon,stele,stbur
- integer yr,jda,ho,mi
- double precision sec
- character(len=20) event_name
-
- ! flags to determine seismogram type
- logical OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY
-
- real(kind=CUSTOM_REAL) phi
-
-! local parameters
- integer time_sec,isample
- character(len=256) sisname_2
- 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,USER4
- 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(len=8) KSTNM
- character(len=16) KEVNM
- character(len=8) KCMPNM
- character(len=8) KNETWK
- character(len=8) KUSER0,KUSER1,KUSER2
- character(len=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
-
- double precision shortest_period
- double precision value1,value2, value3,value4,value5
- logical, external :: is_leap_year
-
- !----------------------------------------------------------------
-
-!######################## 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. I 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 + tshift_cmt) ! [REQUIRED]
- E = BYSAC ! [REQUIRED]
- O = 0 !
- A = undef !###
- !station values:
- STLA = stlat(irec)
- STLO = stlon(irec)
- STEL = stele(irec)
- STDP = stbur(irec)
-
- !event values (hypocenter):
- ! note: this writes out the CMT location, which might be different
- ! to the event location given in the first, PDE line
- EVLA = cmt_lat
- EVLO = cmt_lon
- EVEL = undef !not defined
- EVDP = cmt_depth
-
-
- ! by Ebru
- ! SAC headers will have new format
- USER0 = cmt_hdur !half duration from CMT file if not changed to hdur=0.d0 (point source)
-
- ! USER1 and USER2 slots are used for the shortest and longest periods at which
- ! simulations are accurate, respectively.
- shortest_period = (256/NEX_XI)*(ANGULAR_WIDTH_XI_IN_DEGREES/90)*17
- USER1 = shortest_period
- USER2 = 500.0d0
- ! we remove any PDE information, since the simulation could also start
- ! with a "pure" CMT solution, without having any PDE infos
- !
- !USER1 = t_shift !time shift between PDE and CMT solutions
- !PDE location values (different from CMT location, usually):
- !USER2 = depth !PDE depth
- !USER3 = elat !PDE event latitude
- !USER4 = elon !PDE event longitude
- !
- !cmt location values (different from hypocenter location, usually):
- ! USER0 = cmt_lat
- ! USER1 = cmt_lon
- !USER0 = elat
- !USER1 = elon
- !USER2 = depth
- !USER3 = cmt_hdur !half duration from CMT if not changed to hdur=0.d0 (point source)
-
- ! just to avoid compiler warning
- value1 = elat
- value1 = elon
- value1 = depth
-
-
- ! it is not clear, which magnitude to write out:
- ! should it be
- ! body-wave-magnitude (Mb), surface-wave-magnitude (Ms), moment magnitude (Mw)
- ! or leave magnitude and use scalar moment (M0, but calculated by which convention, Harvard?)
- !
- ! it's confusing, and as a result, we will omit it.
- ! by Ebru
- MAG = undef
- IMAGTYP= undef
-
- !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
-
- ! adds time-shift to get the CMT time in the headers as origin time of events
- ! by Ebru
- NZSEC =int(sec+t_shift)
- NZMSEC =int((sec+t_shift-int(sec+t_shift))*1000)
-
- !NZSEC =int(sec)
- !NZMSEC =int((sec-int(sec))*1000)
-
- ! Adjust event time and date after t_shift is added
- if (NZSEC >= 60) then
- time_sec = jda*24*3600 + ho*3600 + mi*60 + int(sec+t_shift)
- NZJDAY = int(time_sec/(24*3600))
- NZHOUR = int(mod(time_sec,24*3600)/3600)
- NZMIN = int(mod(time_sec,3600)/60)
- NZSEC = mod(time_sec,60)
- if (NZJDAY > 365 .and. .not. is_leap_year(NZYEAR)) then
- NZJDAY = mod(NZJDAY,365)
- NZYEAR = yr + 1
- elseif (NZJDAY > 366 .and. is_leap_year(NZYEAR)) then
- NZJDAY = mod(NZJDAY,366)
- NZYEAR = yr + 1
- elseif (NZJDAY == 366 .and. is_leap_year(NZYEAR)) then
- NZJDAY = 366
- endif
- endif
-
-
- NVHDR=6 ! SAC header version number. Current is 6
-
- ! CSS3.0 variables:
- NORID =int(undef) !origin ID
- NEVID =int(undef) !event ID
- !NWVID =undef !waveform ID
-
- ! NUMBER of POINTS:
- NPTS = it_end-seismo_offset ! [REQUIRED]
- ! event type
- IFTYPE = 1 ! 1=ITIME, i.e. seismogram [REQUIRED] # numbering system is
- IDEP = 6 ! 6: displ/nm # quite strange, best
-
- IZTYPE = 11 !=origint reference time equivalent ! # by chnhdr and write
- IEVTYP = 40 !event type, 40: Earthquake # alpha and check
- IQUAL = int(undef) ! quality
- ISYNTH = int(undef) ! 1 real data, 2...n synth. flag
- ! permission flags:
- LEVEN =1 ! evenly spaced data [REQUIRED]
- LPSPOL=1 ! ? pos. polarity of components (has to be TRUE for LCALDA=1)
- LOVROK=1 ! 1: OK to overwrite file on disk
- LCALDA=1 ! 1: calculate DIST, AZ, BAZ, and GCARC, 0: do nothing
- ! ------------------end format 5I10---------
- !
- !----------------------------------
- KSTNM = station_name(irec)(1:8) ! A8
-
- ! writes out event id as event name
- ! by Ebru
- KEVNM = event_name(1:len_trim(event_name)) ! A16
-
- !if (NSOURCES == 1) then
- ! KEVNM = ename(1:len_trim(ename))//'_syn'! A16
- !else
- ! KEVNM = ename(1:len_trim(ename))//'_sFS'! A16
- !endif
-
- KCMPNM = chn(1:3) ! 3A8
- KNETWK = network_name(irec) ! A6
-
- ! indicates SEM synthetics
- ! by Ebru
- KUSER0 = 'SEM' ! A8
- KUSER1 = 'v5.1.0'
- KUSER2 = 'Tiger' ! aka. awesome (princeton) tiger version :)
-
- !KUSER0 = 'PDE_LAT_' ! A8
- !KUSER1 = 'PDE_LON_' ! A8
- !KUSER2 = 'PDEDEPTH' ! A8
- !----------------------------------
-
- if (OUTPUT_SEISMOS_SAC_ALPHANUM) then
-
- ! add .sacan (sac alphanumeric) extension to seismogram file name for SAC seismograms
- write(sisname_2,"('/',a,'.sacan')") trim(sisname)
- if (seismo_offset == 0) then
- open(unit=IOUT_SAC,file=trim(OUTPUT_FILES)//trim(sisname_2),&
- status='unknown',action='write')
- else
- open(unit=IOUT_SAC,file=trim(OUTPUT_FILES)//trim(sisname_2),&
- status='old', position='append',action='write')
- endif
-
-! Formats of alphanumerical SAC header fields
-510 format(5G15.7,5G15.7,5G15.7,5G15.7,5G15.7)
-520 format(5I10,5I10,5I10,5I10,5I10)
-530 format(A8,A16)
-540 format(A8,A8,A8)
-
-
- if (seismo_offset == 0) then
- !
- ! now write actual header:
- ! ------------------------
- !
- ! real variables:
- ! DELTA DEPMIN DEPMAX SCALE ODELTA
- ! B E O A INTERNAL
- ! T0 T1 T2 T3 T4
- ! T5 T6 T7 T8 T9
- ! F RESP0 RESP1 RESP2 RESP3
- ! RESP4 RESP5 RESP6 RESP7 RESP8
- ! RESP9 STLA STLO STEL STDP
- ! EVLA EVLO EVEL EVDP MAG
- ! USER0 USER1 USER2 USER3 USER4
- ! USER5 USER6 USER7 USER8 USER9
- ! DIST AZ BAZ GCARC INTERNAL
- ! INTERNAL DEPMEN CMPAZ CMPINC XMINIMUM
- ! XMAXIMUM YMINIMUM YMAXIMUM ADJTM UNUSED
- !
- write(IOUT_SAC,510) DELTA, DEPMIN, DEPMAX, SCALE_F, ODELTA
- write(IOUT_SAC,510) B, E, O, A, INTERNAL
- write(IOUT_SAC,510) undef, undef, undef, undef, undef
- write(IOUT_SAC,510) undef, undef, undef, undef, undef
- write(IOUT_SAC,510) undef, undef, undef, undef, undef
- write(IOUT_SAC,510) undef, undef, undef, undef, undef
- write(IOUT_SAC,510) undef, STLA, STLO, STEL, STDP
- write(IOUT_SAC,510) EVLA, EVLO, EVEL, EVDP, MAG
- write(IOUT_SAC,510) USER0, USER1, USER2, undef, undef
- !write(IOUT_SAC,510) USER0, USER1, USER2, USER3, USER4
- write(IOUT_SAC,510) undef, undef, undef, undef, undef
- write(IOUT_SAC,510) DIST, AZ, BAZ, GCARC, INTERNAL
- write(IOUT_SAC,510) INTERNAL, DEPMEN, CMPAZ, CMPINC, undef
- write(IOUT_SAC,510) undef, undef, undef, undef, undef
- write(IOUT_SAC,510) UNUSED, UNUSED, UNUSED, UNUSED, UNUSED
- !
- ! integer variables:
- ! NSPTS, NWFID, NXSIZE, NYSIZE, UNUSED
- ! IINST
- ! ISTREG IEVREG IEVTYP IQUAL ISYNTH
- ! IMAGTYP, IMAGSRC, UNUSED, UNUSED, UNUSED
- !
- write(IOUT_SAC,520) NZYEAR, NZJDAY, NZHOUR, NZMIN, NZSEC
- write(IOUT_SAC,520) NZMSEC, NVHDR, NORID, NEVID, NPTS
- write(IOUT_SAC,520) int(undef),int(undef),int(undef),int(undef),int(undef)
- write(IOUT_SAC,520) IFTYPE, IDEP, IZTYPE, int(UNUSED), int(undef)
- write(IOUT_SAC,520) int(undef),int(undef),IEVTYP, int(undef), ISYNTH
- write(IOUT_SAC,520) IMAGTYP,int(undef),int(undef),int(undef),int(undef)
- write(IOUT_SAC,520) int(UNUSED), int(UNUSED), int(UNUSED), int(UNUSED), int(UNUSED)
- write(IOUT_SAC,520) LEVEN, LPSPOL, LOVROK, LCALDA, int(UNUSED)
- write(IOUT_SAC,530) KSTNM, KEVNM
- !
- ! character variables:
- !
- ! KHOLE KO KA
- ! KT0 KT1 KT2
- ! KT3 KT4 KT5
- ! KT6 KT7 KT8
- ! KT9 KF KUSER0
- ! KUSER1 KUSER2 KCMPNM
- ! KNETWK KDATRD KINST
- !
- write(IOUT_SAC,540) '-12345 ','-12345 ','-12345 '
- write(IOUT_SAC,540) '-12345 ','-12345 ','-12345 '
- write(IOUT_SAC,540) '-12345 ','-12345 ','-12345 '
- write(IOUT_SAC,540) '-12345 ','-12345 ','-12345 '
- write(IOUT_SAC,540) '-12345 ','-12345 ',KUSER0
- write(IOUT_SAC,540) KUSER1, KUSER2, KCMPNM
- write(IOUT_SAC,540) KNETWK,'-12345 ','-12345 '
- endif
-
- ! now write data - with five values per row:
- ! ---------------
-
- do isample = 1+5,seismo_current+1,5
-
- value1 = dble(seismogram_tmp(iorientation,isample-5))
- value2 = dble(seismogram_tmp(iorientation,isample-4))
- value3 = dble(seismogram_tmp(iorientation,isample-3))
- value4 = dble(seismogram_tmp(iorientation,isample-2))
- value5 = dble(seismogram_tmp(iorientation,isample-1))
-
- write(IOUT_SAC,510) sngl(value1),sngl(value2),sngl(value3),sngl(value4),sngl(value5)
-
- enddo
-
- close(IOUT_SAC)
-
- endif ! OUTPUT_SEISMOS_SAC_ALPHANUM
-
- ! For explaination on values set, see above (SAC ASCII)
- if (OUTPUT_SEISMOS_SAC_BINARY) then
-
- ! add .sac (sac binary) extension to seismogram file name for SAC seismograms
- write(sisname_2,"('/',a,'.sac')") trim(sisname)
-
- ! open binary file
- if (seismo_offset == 0) then
- call open_file_create(trim(OUTPUT_FILES)//trim(sisname_2)//char(0))
- else
- call open_file_append(trim(OUTPUT_FILES)//trim(sisname_2)//char(0))
- endif
-
- if (seismo_offset == 0) then
- ! write header variables
-
- ! write single precision header variables 1:70
- call write_real(DELTA) !(1)
- call write_real(DEPMIN) !(2)
- call write_real(DEPMAX) !(3)
- call write_real(SCALE_F) !(4)
- call write_real(ODELTA) !(5)
- call write_real(B) !(6)
- call write_real(E) !(7)
- call write_real(O) !(8)
- call write_real(A) !(9)
- call write_real(INTERNAL) !(10)
- call write_real(undef) !(11)T0
- call write_real(undef) !(12)T1
- call write_real(undef) !(13)T2
- call write_real(undef) !(14)T3
- call write_real(undef) !(15)T4
- call write_real(undef) !(16)T5
- call write_real(undef) !(17)T6
- call write_real(undef) !(18)T7
- call write_real(undef) !(19)T8
- call write_real(undef) !(20)T9
- call write_real(undef) !(21)F
- call write_real(undef) !(22)RESP0
- call write_real(undef) !(23)RESP1
- call write_real(undef) !(24)RESP2
- call write_real(undef) !(25)RESP3
- call write_real(undef) !(26)RESP4
- call write_real(undef) !(27)RESP5
- call write_real(undef) !(28)RESP6
- call write_real(undef) !(29)RESP7
- call write_real(undef) !(30)RESP8
- call write_real(undef) !(31)RESP9
- call write_real(STLA) !(32)
- call write_real(STLO) !(33)
- call write_real(STEL) !(34)
- call write_real(STDP) !(35)
- call write_real(EVLA) !(36)
- call write_real(EVLO) !(37)
- call write_real(EVEL) !(38)
- call write_real(EVDP) !(39)
- call write_real(MAG) !(40)
- call write_real(USER0) !(41)USER0
- call write_real(USER1) !(42)USER1
- call write_real(USER2) !(43)USER2
- call write_real(undef) !(44)USER3
- call write_real(undef) !(45)USER4
- call write_real(undef) !(46)USER5
- call write_real(undef) !(47)USER6
- call write_real(undef) !(48)USER7
- call write_real(undef) !(49)USER8
- call write_real(undef) !(50)USER9
- call write_real(DIST) !(51)
- call write_real(AZ) !(52)
- call write_real(BAZ) !(53)
- call write_real(GCARC) !(54)
- call write_real(INTERNAL) !(55)
- call write_real(INTERNAL) !(56)
- call write_real(DEPMEN) !(57)
- call write_real(CMPAZ) !(58)
- call write_real(CMPINC) !(59)
- call write_real(undef) !(60)XMINIMUM
- call write_real(undef) !(61)XMAXIMUM
- call write_real(undef) !(62)YMINIMUM
- call write_real(undef) !(63)YMAXIMUM
- call write_real(undef) !(64)
- call write_real(undef) !(65)
- call write_real(undef) !(66)
- call write_real(undef) !(67)
- call write_real(undef) !(68)
- call write_real(undef) !(69)
- call write_real(undef) !(70)
-
- ! write integer header variables 71:105
- call write_integer(NZYEAR) !(71)
- call write_integer(NZJDAY) !(72)
- call write_integer(NZHOUR) !(73)
- call write_integer(NZMIN) !(74)
- call write_integer(NZSEC) !(75)
- call write_integer(NZMSEC) !(76)
- call write_integer(NVHDR) !(77)
- call write_integer(NORID) !(78)
- call write_integer(NEVID) !(79)
- call write_integer(NPTS) !(80)
- call write_integer(int(undef)) !(81)UNUSED
- call write_integer(int(undef)) !(82)NWFID
- call write_integer(int(undef)) !(83)NXSIZE
- call write_integer(int(undef)) !(84)NYSIZE
- call write_integer(int(undef)) !(85)UNUSED
- call write_integer(IFTYPE) !(86)
- call write_integer(IDEP) !(87)
- call write_integer(IZTYPE) !(88)
- call write_integer(int(undef)) !(89)UNUSED
- call write_integer(int(undef)) !(90)IINST
- call write_integer(int(undef)) !(91)ISTREG
- call write_integer(int(undef)) !(92)IEVREG
- call write_integer(IEVTYP) !(93)
- call write_integer(int(undef)) !(94)IQUAL
- call write_integer(ISYNTH) !(95)
- call write_integer(IMAGTYP) !(96)
- call write_integer(int(undef)) !(97)IMAGSRC
- call write_integer(int(UNUSED)) !(98)
- call write_integer(int(UNUSED)) !(99)
- call write_integer(int(UNUSED)) !(100)
- call write_integer(int(UNUSED)) !(101)
- call write_integer(int(UNUSED)) !(102)
- call write_integer(int(UNUSED)) !(103)
- call write_integer(int(UNUSED)) !(104)
- call write_integer(int(UNUSED)) !(105)
-
- ! write logical header variables 106:110
- call write_integer(LEVEN) !(106)
- call write_integer(LPSPOL) !(107)
- call write_integer(LOVROK) !(108)
- call write_integer(LCALDA) !(109)
- call write_integer(int(UNUSED)) !(110)
-
-
- ! write character header variables 111:302
- call write_character(KSTNM,8) !(111:118)
- call write_character(KEVNM,16) !(119:134)
- call write_character(str_undef,8) !(135:142)KHOLE
- call write_character(str_undef,8) !(143:150)KO
- call write_character(str_undef,8) !(151:158)KA
- call write_character(str_undef,8) !(159:166)KT0
- call write_character(str_undef,8) !(167:174)KT1
- call write_character(str_undef,8) !(175:182)KT2
- call write_character(str_undef,8) !(183:190)KT3
- call write_character(str_undef,8) !(191:198)KT4
- call write_character(str_undef,8) !(199:206)KT5
- call write_character(str_undef,8) !(207:214)KT6
- call write_character(str_undef,8) !(215:222)KT7
- call write_character(str_undef,8) !(223:230)KT8
- call write_character(str_undef,8) !(231:238)KT9
- call write_character(str_undef,8) !(239:246)KF
- call write_character(KUSER0,8) !(247:254)
- call write_character(KUSER1,8) !(255:262)
- call write_character(KUSER2,8) !(263:270)
- call write_character(KCMPNM,8) !(271:278)
- call write_character(KNETWK,8) !(279:286)
- call write_character(str_undef,8) !(287:294)KDATRD
- call write_character(str_undef,8) !(295:302)KINST
-
- endif
-
- ! now write SAC time series to file
- ! BS BS write whole time series at once (hope to increase I/O performance
- ! compared to using a loop on it)
-
- if (CUSTOM_REAL == SIZE_REAL) then
- call write_n_real(seismogram_tmp(iorientation,1:seismo_current),seismo_current)
- elseif (CUSTOM_REAL == SIZE_DOUBLE) then
- call write_n_real(real(seismogram_tmp(iorientation,1:seismo_current)),seismo_current)
- endif
-
- call close_file()
-
- endif ! OUTPUT_SEISMOS_SAC_BINARY
-
-!#################### end SAC Alphanumeric Seismos ############################
-
- end subroutine write_output_SAC
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_seismograms.f90 2011-02-25 22:33:46 UTC (rev 17977)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_seismograms.f90 2011-02-25 22:36:07 UTC (rev 17978)
@@ -1,594 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! February 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! write seismograms to files
- subroutine write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,stbur, &
- nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
- yr,jda,ho,mi,sec,tshift_cmt,t_shift, &
- elat,elon,depth,event_name,cmt_lat,cmt_lon, &
- cmt_depth,cmt_hdur,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,NEX_XI !,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,ANGULAR_WIDTH_XI_IN_DEGREES
-
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
- double precision tshift_cmt,t_shift,elat,elon,depth
- double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
- double precision, dimension(nrec) :: stlat,stlon,stele,stbur
- integer yr,jda,ho,mi
- double precision sec
- !real mb
-! character(len=12) ename
- character(len=20) event_name
-
-! 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',action='write')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
- form='unformatted',position='append',action='write')
- endif
- else
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted',action='write')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='old',&
- form='formatted',position='append',action='write')
- endif
- endif
- endif
-
- total_seismos_local = 0
-
- ! loop on all the local receivers
- do irec_local = 1,nrec_local
-
- ! get global number of that receiver
- irec = number_receiver_global(irec_local)
-
- total_seismos_local = total_seismos_local + 1
-
- one_seismogram = seismograms(:,irec_local,:)
-
- ! write this seismogram
- call write_one_seismogram(one_seismogram,irec, &
- station_name,network_name,stlat,stlon,stele,stbur,nrec, &
- ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
- yr,jda,ho,mi,sec,tshift_cmt,t_shift, &
- elat,elon,depth,event_name,cmt_lat, &
- cmt_lon,cmt_depth,cmt_hdur,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
-
- ! 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) close(IOUT)
-
- if(total_seismos_local/= nrec_local) call exit_MPI(myrank,'incorrect total number of receivers saved')
-
- write_time = MPI_WTIME() - write_time_begin
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'Writing the seismograms in parallel took ',write_time,' seconds'
- write(IMAIN,*)
- endif
-
- ! now only the master process does the writing of seismograms and
- ! collects the data from all other processes
- else ! WRITE_SEISMOGRAMS_BY_MASTER
-
- write_time_begin = MPI_WTIME()
-
- if(myrank == 0) then ! on the master, gather all the seismograms
-
- ! create one large file instead of one small file per station to avoid file system overload
- if(OUTPUT_SEISMOS_ASCII_TEXT .and. SAVE_ALL_SEISMOS_IN_ONE_FILE) then
- write(sisname,'(A)') '/all_seismograms'
-
- if(USE_BINARY_FOR_LARGE_FILE) then
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='unknown',form='unformatted',action='write')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
- form='unformatted',position='append',action='write')
- endif
- else
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted',action='write')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='old',&
- form='formatted',position='append',action='write')
- endif
- endif
-
- endif
-
- total_seismos = 0
-
- ! loop on all the slices
- do iproc = 0,NPROCTOT-1
-
- ! receive except from proc 0, which is me and therefore I already have this value
- sender = iproc
- if(iproc /= 0) then
- call MPI_RECV(nrec_local_received,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- if(nrec_local_received < 0) call exit_MPI(myrank,'error while receiving local number of receivers')
- else
- nrec_local_received = nrec_local
- endif
- if (nrec_local_received > 0) then
- do irec_local = 1,nrec_local_received
- ! receive except from proc 0, which is myself and therefore I already have these values
- if(iproc == 0) then
- ! get global number of that receiver
- irec = number_receiver_global(irec_local)
- one_seismogram(:,:) = seismograms(:,irec_local,:)
- else
- call MPI_RECV(irec,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- if(irec < 1 .or. irec > nrec) call exit_MPI(myrank,'error while receiving global receiver number')
- call MPI_RECV(one_seismogram,NDIM*seismo_current,CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- endif
-
- total_seismos = total_seismos + 1
- ! write this seismogram
- call write_one_seismogram(one_seismogram,irec, &
- station_name,network_name,stlat,stlon,stele,stbur,nrec, &
- ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
- yr,jda,ho,mi,sec,tshift_cmt,t_shift, &
- elat,elon,depth,event_name,cmt_lat, &
- cmt_lon,cmt_depth,cmt_hdur,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,stbur,nrec, &
- ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
- yr,jda,ho,mi,sec,tshift_cmt,t_shift,&
- elat,elon,depth,event_name,cmt_lat,cmt_lon,cmt_depth,cmt_hdur, &
- 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,NEX_XI
-
- 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,ANGULAR_WIDTH_XI_IN_DEGREES
-
- 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
-
- character(len=4) chn
- character(len=256) sisname,sisname_big_file
- character(len=150) OUTPUT_FILES
-
- ! section added for SAC
- double precision tshift_cmt,t_shift,elat,elon,depth
- double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
-
- double precision, dimension(nrec) :: stlat,stlon,stele,stbur
-
- ! variables for SAC header fields
- integer yr,jda,ho,mi
- double precision sec
- character(len=20) event_name
-
- ! 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
-
-! local parameters
- character(len=2) bic
- ! 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
- integer isample
-
- !----------------------------------------------------------------
-
- call band_instrument_code(DT,bic)
- 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'
- chn = bic(1:2)//'N'
- else if(iorientation == 2) then
- !chn = 'LHE'
- chn = bic(1:2)//'E'
- else if(iorientation == 3) then
- !chn = 'LHZ'
- chn = bic(1:2)//'Z'
- else if(iorientation == 4) then
- !chn = 'LHR'
- chn = bic(1:2)//'R'
- else if(iorientation == 5) then
- !chn = 'LHT'
- chn = bic(1:2)//'T'
- 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
- ! call get_backazimuth(elat,elon,stlat(irec),stlon(irec),backaz)
- call get_backazimuth(cmt_lat,cmt_lon,stlat(irec),stlon(irec),backaz)
-
- phi = backaz
- if (phi>180.) then
- phi = phi-180.
- elseif (phi<180.) then
- phi = phi+180.
- elseif (phi==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,'.sem')") 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,'.sem')") station_name(irec)(1:length_station_name), &
- network_name(irec)(1:length_network_name),chn
-
- ! SAC output format
- if (OUTPUT_SEISMOS_SAC_ALPHANUM .or. OUTPUT_SEISMOS_SAC_BINARY) then
-
- call write_output_SAC(seismogram_tmp,irec, &
- station_name,network_name,stlat,stlon,stele,stbur,nrec, &
- ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,hdur,it_end, &
- yr,jda,ho,mi,sec,tshift_cmt,t_shift,&
- elat,elon,depth,event_name,cmt_lat,cmt_lon,cmt_depth,cmt_hdur, &
- OUTPUT_FILES, &
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
- iorientation,phi,chn,sisname)
-
- endif ! OUTPUT_SEISMOS_SAC_ALPHANUM .or. OUTPUT_SEISMOS_SAC_BINARY
-
- ! ASCII output format
- if(OUTPUT_SEISMOS_ASCII_TEXT) then
-
- call write_output_ASCII(seismogram_tmp, &
- DT,hdur,OUTPUT_FILES, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank, &
- iorientation,sisname,sisname_big_file)
-
- endif ! OUTPUT_SEISMOS_ASCII_TEXT
-
- enddo ! do iorientation
-
- end subroutine write_one_seismogram
-
-!=====================================================================
-
-! write adjoint seismograms to text files
-
- subroutine write_adj_seismograms(seismograms,number_receiver_global, &
- nrec_local,it,nit_written,DT,NSTEP, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,hdur,LOCAL_PATH)
-
- implicit none
-
- include "constants.h"
-
- integer nrec_local,NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,it,nit_written
- integer, dimension(nrec_local) :: number_receiver_global
- real(kind=CUSTOM_REAL), dimension(9,nrec_local,NSTEP) :: seismograms
- double precision hdur,DT
- character(len=150) LOCAL_PATH
-
- integer irec,irec_local
- integer iorientation,isample
-
- character(len=4) chn
- character(len=150) clean_LOCAL_PATH,final_LOCAL_PATH
- character(len=256) sisname
- character(len=2) bic
-
- call band_instrument_code(DT,bic)
-
- do irec_local = 1,nrec_local
-
-! get global number of that receiver
- irec = number_receiver_global(irec_local)
-
- do iorientation = 1,9
-
- if(iorientation == 1) then
- chn = 'SNN'
- else if(iorientation == 2) then
- chn = 'SEE'
- else if(iorientation == 3) then
- chn = 'SZZ'
- else if(iorientation == 4) then
- chn = 'SNE'
- else if(iorientation == 5) then
- chn = 'SNZ'
- else if(iorientation == 6) then
- chn = 'SEZ'
- else if(iorientation == 7) then
- !chn = 'LHN'
- chn = bic(1:2)//'N'
- else if(iorientation == 8) then
- chn = bic(1:2)//'E'
- else if(iorientation == 9) then
- chn = bic(1:2)//'Z'
- endif
-
-
-! create the name of the seismogram file for each slice
-! file name includes the name of the station, the network and the component
- write(sisname,"(a,i6.6,'.',a,'.',a3,'.sem')") 'S',irec,'NT',chn
-
-! suppress white spaces if any
- clean_LOCAL_PATH = adjustl(LOCAL_PATH)
-
-! create full final local path
- final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
-
-! 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
- if(it <= NTSTEP_BETWEEN_OUTPUT_SEISMOS) then
- !open new file
- open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),&
- status='unknown',action='write')
- else if(it > NTSTEP_BETWEEN_OUTPUT_SEISMOS) then
- !append to existing file
- open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),&
- status='old',position='append',action='write')
- endif
-! make sure we never write more than the maximum number of time steps
-! subtract half duration of the source to make sure travel time is correct
- do isample = nit_written+1,min(it,NSTEP)
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IOUT,*) sngl(dble(isample-1)*DT - hdur),' ',seismograms(iorientation,irec_local,isample-nit_written)
- else
- write(IOUT,*) dble(isample-1)*DT - hdur,' ',seismograms(iorientation,irec_local,isample-nit_written)
- endif
- enddo
-
- close(IOUT)
-
- enddo
-
- enddo
-
- end subroutine write_adj_seismograms
-
-!=====================================================================
-
- subroutine band_instrument_code(DT,bic)
- ! This subroutine is to choose the appropriate band and instrument codes for channel names of seismograms
- ! based on the IRIS convention (first two letters of channel codes which were LH(Z/E/N) previously).
- ! For consistency with observed data, we now use the IRIS convention for band codes (first letter in channel codes)of
- ! SEM seismograms governed by their sampling rate.
- ! Instrument code (second letter in channel codes) is fixed to "X" which is assigned by IRIS for synthetic seismograms.
- ! See the manual for further explanations!
- ! Ebru, November 2010
- implicit none
- double precision DT
- character(len=2) bic
-
- if (DT .ge. 1.0d0) bic = 'LX'
- if (DT .lt. 1.0d0 .and. DT .gt. 0.1d0) bic = 'MX'
- if (DT .le. 0.1d0 .and. DT .gt. 0.0125d0) bic = 'BX'
- if (DT .le. 0.0125d0 .and. DT .gt. 0.004d0) bic = 'HX'
- if (DT .le. 0.004d0 .and. DT .gt. 0.001d0) bic = 'CX'
- if (DT .le. 0.001d0) bic = 'FX'
-
- end subroutine band_instrument_code
More information about the CIG-COMMITS
mailing list